From 2535383aad859f157d2fa8f0b14fbf62fa367add Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 27 May 2008 09:09:26 +0000 Subject: [PATCH] mld2p4: config/pac.m4 configure krylov/Makefile krylov/psb_prec_mod.F90 mlprec/Makefile mlprec/mld_basep_bld_mod.f90 mlprec/mld_caggrmap_bld.f90 mlprec/mld_caggrmat_asb.f90 mlprec/mld_caggrmat_raw_asb.F90 mlprec/mld_caggrmat_smth_asb.F90 mlprec/mld_cas_aply.f90 mlprec/mld_cas_bld.f90 mlprec/mld_cbaseprec_aply.f90 mlprec/mld_cbaseprec_bld.f90 mlprec/mld_cdiag_bld.f90 mlprec/mld_cfact_bld.f90 mlprec/mld_cilu0_fact.f90 mlprec/mld_cilu_bld.f90 mlprec/mld_ciluk_fact.f90 mlprec/mld_cilut_fact.f90 mlprec/mld_cmlprec_aply.f90 mlprec/mld_cmlprec_bld.f90 mlprec/mld_cprec_aply.f90 mlprec/mld_cprecbld.f90 mlprec/mld_cprecfree.f90 mlprec/mld_cprecinit.f90 mlprec/mld_cprecset.f90 mlprec/mld_cslu_bld.f90 mlprec/mld_cslu_interface.c mlprec/mld_cslud_bld.f90 mlprec/mld_cslud_interface.c mlprec/mld_csp_renum.f90 mlprec/mld_csub_aply.f90 mlprec/mld_csub_solve.f90 mlprec/mld_cumf_bld.f90 mlprec/mld_cumf_interface.c mlprec/mld_dmlprec_bld.f90 mlprec/mld_dprecset.f90 mlprec/mld_inner_mod.f90 mlprec/mld_prec_mod.f90 mlprec/mld_prec_type.f90 mlprec/mld_saggrmap_bld.f90 mlprec/mld_saggrmat_asb.f90 mlprec/mld_saggrmat_raw_asb.F90 mlprec/mld_saggrmat_smth_asb.F90 mlprec/mld_sas_aply.f90 mlprec/mld_sas_bld.f90 mlprec/mld_sbaseprec_aply.f90 mlprec/mld_sbaseprec_bld.f90 mlprec/mld_sdiag_bld.f90 mlprec/mld_sfact_bld.f90 mlprec/mld_silu0_fact.f90 mlprec/mld_silu_bld.f90 mlprec/mld_siluk_fact.f90 mlprec/mld_silut_fact.f90 mlprec/mld_smlprec_aply.f90 mlprec/mld_smlprec_bld.f90 mlprec/mld_sprec_aply.f90 mlprec/mld_sprecbld.f90 mlprec/mld_sprecfree.f90 mlprec/mld_sprecinit.f90 mlprec/mld_sprecset.f90 mlprec/mld_sslu_bld.f90 mlprec/mld_sslu_interface.c mlprec/mld_sslud_bld.f90 mlprec/mld_sslud_interface.c mlprec/mld_ssp_renum.f90 mlprec/mld_ssub_aply.f90 mlprec/mld_ssub_solve.f90 mlprec/mld_sumf_bld.f90 mlprec/mld_sumf_interface.c mlprec/mld_zilu0_fact.f90 mlprec/mld_zmlprec_aply.f90 mlprec/mld_zmlprec_bld.f90 mlprec/mld_zprecset.f90 test/fileread/Makefile test/fileread/cf_sample.f90 test/fileread/data_input.f90 test/fileread/df_sample.f90 test/fileread/runs/cfs.inp test/fileread/runs/dfs.inp test/fileread/runs/sfs.inp test/fileread/runs/zfs.inp test/fileread/sf_sample.f90 test/fileread/zf_sample.f90 test/pargen/Makefile test/pargen/runs/ppde.inp test/pargen/spde.f90 Merged single precision version. --- config/pac.m4 | 2 +- configure | 4 +- krylov/Makefile | 6 +- krylov/psb_prec_mod.F90 | 4 + mlprec/Makefile | 32 +- mlprec/mld_basep_bld_mod.f90 | 208 +++++ mlprec/mld_caggrmap_bld.f90 | 391 ++++++++ mlprec/mld_caggrmat_asb.f90 | 160 ++++ mlprec/mld_caggrmat_raw_asb.F90 | 284 ++++++ mlprec/mld_caggrmat_smth_asb.F90 | 666 ++++++++++++++ mlprec/mld_cas_aply.f90 | 407 +++++++++ mlprec/mld_cas_bld.f90 | 287 ++++++ mlprec/mld_cbaseprec_aply.f90 | 193 ++++ mlprec/mld_cbaseprec_bld.f90 | 217 +++++ mlprec/mld_cdiag_bld.f90 | 159 ++++ mlprec/mld_cfact_bld.f90 | 485 ++++++++++ mlprec/mld_cilu0_fact.f90 | 648 ++++++++++++++ mlprec/mld_cilu_bld.f90 | 280 ++++++ mlprec/mld_ciluk_fact.f90 | 971 ++++++++++++++++++++ mlprec/mld_cilut_fact.f90 | 1159 ++++++++++++++++++++++++ mlprec/mld_cmlprec_aply.f90 | 1439 ++++++++++++++++++++++++++++++ mlprec/mld_cmlprec_bld.f90 | 180 ++++ mlprec/mld_cprec_aply.f90 | 261 ++++++ mlprec/mld_cprecbld.f90 | 234 +++++ mlprec/mld_cprecfree.f90 | 94 ++ mlprec/mld_cprecinit.f90 | 252 ++++++ mlprec/mld_cprecset.f90 | 637 +++++++++++++ mlprec/mld_cslu_bld.f90 | 129 +++ mlprec/mld_cslu_interface.c | 399 +++++++++ mlprec/mld_cslud_bld.f90 | 149 ++++ mlprec/mld_cslud_interface.c | 402 +++++++++ mlprec/mld_csp_renum.f90 | 368 ++++++++ mlprec/mld_csub_aply.f90 | 296 ++++++ mlprec/mld_csub_solve.f90 | 325 +++++++ mlprec/mld_cumf_bld.f90 | 138 +++ mlprec/mld_cumf_interface.c | 258 ++++++ mlprec/mld_dmlprec_bld.f90 | 2 +- mlprec/mld_dprecset.f90 | 12 +- mlprec/mld_inner_mod.f90 | 238 +++++ mlprec/mld_prec_mod.f90 | 150 +++- mlprec/mld_prec_type.f90 | 594 +++++++++++- mlprec/mld_saggrmap_bld.f90 | 390 ++++++++ mlprec/mld_saggrmat_asb.f90 | 160 ++++ mlprec/mld_saggrmat_raw_asb.F90 | 284 ++++++ mlprec/mld_saggrmat_smth_asb.F90 | 666 ++++++++++++++ mlprec/mld_sas_aply.f90 | 407 +++++++++ mlprec/mld_sas_bld.f90 | 287 ++++++ mlprec/mld_sbaseprec_aply.f90 | 189 ++++ mlprec/mld_sbaseprec_bld.f90 | 217 +++++ mlprec/mld_sdiag_bld.f90 | 159 ++++ mlprec/mld_sfact_bld.f90 | 484 ++++++++++ mlprec/mld_silu0_fact.f90 | 648 ++++++++++++++ mlprec/mld_silu_bld.f90 | 280 ++++++ mlprec/mld_siluk_fact.f90 | 971 ++++++++++++++++++++ mlprec/mld_silut_fact.f90 | 1158 ++++++++++++++++++++++++ mlprec/mld_smlprec_aply.f90 | 1435 +++++++++++++++++++++++++++++ mlprec/mld_smlprec_bld.f90 | 180 ++++ mlprec/mld_sprec_aply.f90 | 260 ++++++ mlprec/mld_sprecbld.f90 | 234 +++++ mlprec/mld_sprecfree.f90 | 94 ++ mlprec/mld_sprecinit.f90 | 252 ++++++ mlprec/mld_sprecset.f90 | 637 +++++++++++++ mlprec/mld_sslu_bld.f90 | 129 +++ mlprec/mld_sslu_interface.c | 391 ++++++++ mlprec/mld_sslud_bld.f90 | 148 +++ mlprec/mld_sslud_interface.c | 401 +++++++++ mlprec/mld_ssp_renum.f90 | 368 ++++++++ mlprec/mld_ssub_aply.f90 | 296 ++++++ mlprec/mld_ssub_solve.f90 | 312 +++++++ mlprec/mld_sumf_bld.f90 | 138 +++ mlprec/mld_sumf_interface.c | 258 ++++++ mlprec/mld_zilu0_fact.f90 | 2 +- mlprec/mld_zmlprec_aply.f90 | 14 +- mlprec/mld_zmlprec_bld.f90 | 2 +- mlprec/mld_zprecset.f90 | 12 +- test/fileread/Makefile | 28 +- test/fileread/cf_sample.f90 | 454 ++++++++++ test/fileread/data_input.f90 | 91 ++ test/fileread/df_sample.f90 | 73 +- test/fileread/runs/cfs.inp | 29 + test/fileread/runs/dfs.inp | 12 +- test/fileread/runs/sfs.inp | 29 + test/fileread/runs/zfs.inp | 29 + test/fileread/sf_sample.f90 | 454 ++++++++++ test/fileread/zf_sample.f90 | 454 ++++++++++ test/pargen/Makefile | 7 +- test/pargen/runs/ppde.inp | 11 +- test/pargen/spde.f90 | 795 +++++++++++++++++ 88 files changed, 27325 insertions(+), 124 deletions(-) create mode 100644 mlprec/mld_caggrmap_bld.f90 create mode 100644 mlprec/mld_caggrmat_asb.f90 create mode 100644 mlprec/mld_caggrmat_raw_asb.F90 create mode 100644 mlprec/mld_caggrmat_smth_asb.F90 create mode 100644 mlprec/mld_cas_aply.f90 create mode 100644 mlprec/mld_cas_bld.f90 create mode 100644 mlprec/mld_cbaseprec_aply.f90 create mode 100644 mlprec/mld_cbaseprec_bld.f90 create mode 100644 mlprec/mld_cdiag_bld.f90 create mode 100644 mlprec/mld_cfact_bld.f90 create mode 100644 mlprec/mld_cilu0_fact.f90 create mode 100644 mlprec/mld_cilu_bld.f90 create mode 100644 mlprec/mld_ciluk_fact.f90 create mode 100644 mlprec/mld_cilut_fact.f90 create mode 100644 mlprec/mld_cmlprec_aply.f90 create mode 100644 mlprec/mld_cmlprec_bld.f90 create mode 100644 mlprec/mld_cprec_aply.f90 create mode 100644 mlprec/mld_cprecbld.f90 create mode 100644 mlprec/mld_cprecfree.f90 create mode 100644 mlprec/mld_cprecinit.f90 create mode 100644 mlprec/mld_cprecset.f90 create mode 100644 mlprec/mld_cslu_bld.f90 create mode 100644 mlprec/mld_cslu_interface.c create mode 100644 mlprec/mld_cslud_bld.f90 create mode 100644 mlprec/mld_cslud_interface.c create mode 100644 mlprec/mld_csp_renum.f90 create mode 100644 mlprec/mld_csub_aply.f90 create mode 100644 mlprec/mld_csub_solve.f90 create mode 100644 mlprec/mld_cumf_bld.f90 create mode 100644 mlprec/mld_cumf_interface.c create mode 100644 mlprec/mld_saggrmap_bld.f90 create mode 100644 mlprec/mld_saggrmat_asb.f90 create mode 100644 mlprec/mld_saggrmat_raw_asb.F90 create mode 100644 mlprec/mld_saggrmat_smth_asb.F90 create mode 100644 mlprec/mld_sas_aply.f90 create mode 100644 mlprec/mld_sas_bld.f90 create mode 100644 mlprec/mld_sbaseprec_aply.f90 create mode 100644 mlprec/mld_sbaseprec_bld.f90 create mode 100644 mlprec/mld_sdiag_bld.f90 create mode 100644 mlprec/mld_sfact_bld.f90 create mode 100644 mlprec/mld_silu0_fact.f90 create mode 100644 mlprec/mld_silu_bld.f90 create mode 100644 mlprec/mld_siluk_fact.f90 create mode 100644 mlprec/mld_silut_fact.f90 create mode 100644 mlprec/mld_smlprec_aply.f90 create mode 100644 mlprec/mld_smlprec_bld.f90 create mode 100644 mlprec/mld_sprec_aply.f90 create mode 100644 mlprec/mld_sprecbld.f90 create mode 100644 mlprec/mld_sprecfree.f90 create mode 100644 mlprec/mld_sprecinit.f90 create mode 100644 mlprec/mld_sprecset.f90 create mode 100644 mlprec/mld_sslu_bld.f90 create mode 100644 mlprec/mld_sslu_interface.c create mode 100644 mlprec/mld_sslud_bld.f90 create mode 100644 mlprec/mld_sslud_interface.c create mode 100644 mlprec/mld_ssp_renum.f90 create mode 100644 mlprec/mld_ssub_aply.f90 create mode 100644 mlprec/mld_ssub_solve.f90 create mode 100644 mlprec/mld_sumf_bld.f90 create mode 100644 mlprec/mld_sumf_interface.c create mode 100644 test/fileread/cf_sample.f90 create mode 100644 test/fileread/data_input.f90 create mode 100644 test/fileread/runs/cfs.inp create mode 100644 test/fileread/runs/sfs.inp create mode 100644 test/fileread/runs/zfs.inp create mode 100644 test/fileread/sf_sample.f90 create mode 100644 test/fileread/zf_sample.f90 create mode 100644 test/pargen/spde.f90 diff --git a/config/pac.m4 b/config/pac.m4 index d6e39498..02e9a5a2 100644 --- a/config/pac.m4 +++ b/config/pac.m4 @@ -696,7 +696,7 @@ if test "x$mld2p4_cv_superludistdir" != "x"; then fi LIBS="$SLUDIST_LIBS $LIBS" CPPFLAGS="$SLUDIST_INCLUDES $CPPFLAGS" -AC_MSG_NOTICE([slu dir $mld2p4_cv_superludistdir]) +AC_MSG_NOTICE([sludist dir $mld2p4_cv_superludistdir]) AC_CHECK_HEADER([superlu_ddefs.h], [pac_sludist_header_ok=yes], [pac_sludist_header_ok=no; SLUDIST_INCLUDES=""]) diff --git a/configure b/configure index c2726b20..e0591f0e 100755 --- a/configure +++ b/configure @@ -4346,8 +4346,8 @@ if test "x$mld2p4_cv_superludistdir" != "x"; then fi LIBS="$SLUDIST_LIBS $LIBS" CPPFLAGS="$SLUDIST_INCLUDES $CPPFLAGS" -{ echo "$as_me:$LINENO: slu dir $mld2p4_cv_superludistdir" >&5 -echo "$as_me: slu dir $mld2p4_cv_superludistdir" >&6;} +{ echo "$as_me:$LINENO: sludist dir $mld2p4_cv_superludistdir" >&5 +echo "$as_me: sludist dir $mld2p4_cv_superludistdir" >&6;} if test "${ac_cv_header_superlu_ddefs_h+set}" = set; then { echo "$as_me:$LINENO: checking for superlu_ddefs.h" >&5 echo $ECHO_N "checking for superlu_ddefs.h... $ECHO_C" >&6; } diff --git a/krylov/Makefile b/krylov/Makefile index 5f0cbf7c..46d64c1d 100644 --- a/krylov/Makefile +++ b/krylov/Makefile @@ -12,8 +12,12 @@ HERE=. FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBLIBDIR) PSBKRYLDIR=$(PSBLASDIR)/krylov -METHDOBJS=psb_dcgstab.o psb_dcg.o psb_dcgs.o \ +METHDOBJS= psb_dcgstab.o psb_dcg.o psb_dcgs.o \ psb_dbicg.o psb_dcgstabl.o psb_drgmres.o\ + psb_scgstab.o psb_scg.o psb_scgs.o \ + psb_sbicg.o psb_scgstabl.o psb_srgmres.o\ + psb_ccgstab.o psb_ccg.o psb_ccgs.o \ + psb_cbicg.o psb_ccgstabl.o psb_crgmres.o\ psb_zcgstab.o psb_zcg.o psb_zcgs.o \ psb_zbicg.o psb_zcgstabl.o psb_zrgmres.o diff --git a/krylov/psb_prec_mod.F90 b/krylov/psb_prec_mod.F90 index a8936eda..d15a1837 100644 --- a/krylov/psb_prec_mod.F90 +++ b/krylov/psb_prec_mod.F90 @@ -95,9 +95,13 @@ module psb_prec_mod #else use mld_prec_mod, & + & psb_sbaseprc_type => mld_sbaseprc_type,& & psb_dbaseprc_type => mld_dbaseprc_type,& + & psb_cbaseprc_type => mld_cbaseprc_type,& & psb_zbaseprc_type => mld_zbaseprc_type,& + & psb_sprec_type => mld_sprec_type,& & psb_dprec_type => mld_dprec_type,& + & psb_cprec_type => mld_cprec_type,& & psb_zprec_type => mld_zprec_type,& & psb_base_precfree => mld_base_precfree,& & psb_nullify_baseprec => mld_nullify_baseprec,& diff --git a/mlprec/Makefile b/mlprec/Makefile index c4812089..5e5ee233 100644 --- a/mlprec/Makefile +++ b/mlprec/Makefile @@ -7,30 +7,52 @@ FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBLIBDIR) MODOBJS=mld_prec_type.o mld_prec_mod.o mld_inner_mod.o mld_basep_bld_mod.o -MPFOBJS=mld_daggrmat_raw_asb.o mld_daggrmat_smth_asb.o \ +MPFOBJS=mld_saggrmat_raw_asb.o mld_saggrmat_smth_asb.o \ + mld_daggrmat_raw_asb.o mld_daggrmat_smth_asb.o \ + mld_caggrmat_raw_asb.o mld_caggrmat_smth_asb.o \ mld_zaggrmat_raw_asb.o mld_zaggrmat_smth_asb.o -MPCOBJS=mld_dslud_interface.o mld_zslud_interface.o -INNEROBJS=mld_das_bld.o mld_dslu_bld.o mld_dumf_bld.o mld_dilu0_fact.o\ +MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o +INNEROBJS=mld_sas_bld.o mld_sslu_bld.o mld_sumf_bld.o mld_silu0_fact.o\ + mld_smlprec_bld.o mld_ssp_renum.o mld_sfact_bld.o mld_silu_bld.o \ + mld_sbaseprec_bld.o mld_sdiag_bld.o mld_saggrmap_bld.o \ + mld_smlprec_aply.o mld_sslud_bld.o\ + mld_sbaseprec_aply.o mld_ssub_aply.o mld_ssub_solve.o \ + mld_sas_aply.o mld_saggrmat_asb.o \ + mld_das_bld.o mld_dslu_bld.o mld_dumf_bld.o mld_dilu0_fact.o\ mld_dmlprec_bld.o mld_dsp_renum.o mld_dfact_bld.o mld_dilu_bld.o \ mld_dbaseprec_bld.o mld_ddiag_bld.o mld_daggrmap_bld.o \ mld_dmlprec_aply.o mld_dslud_bld.o\ mld_dbaseprec_aply.o mld_dsub_aply.o mld_dsub_solve.o \ mld_das_aply.o mld_daggrmat_asb.o \ + mld_cas_bld.o mld_cslu_bld.o mld_cumf_bld.o mld_cilu0_fact.o\ + mld_cmlprec_bld.o mld_csp_renum.o mld_cfact_bld.o mld_cilu_bld.o \ + mld_cbaseprec_bld.o mld_cdiag_bld.o mld_caggrmap_bld.o \ + mld_cmlprec_aply.o mld_cslud_bld.o\ + mld_cbaseprec_aply.o mld_csub_aply.o mld_csub_solve.o \ + mld_cas_aply.o mld_caggrmat_asb.o\ mld_zas_bld.o mld_zslu_bld.o mld_zumf_bld.o mld_zilu0_fact.o\ mld_zmlprec_bld.o mld_zsp_renum.o mld_zfact_bld.o mld_zilu_bld.o \ mld_zbaseprec_bld.o mld_zdiag_bld.o mld_zaggrmap_bld.o \ mld_zmlprec_aply.o mld_zslud_bld.o\ mld_zbaseprec_aply.o mld_zsub_aply.o mld_zsub_solve.o \ mld_zas_aply.o mld_zaggrmat_asb.o\ + mld_siluk_fact.o mld_ciluk_fact.o mld_silut_fact.o mld_cilut_fact.o \ mld_diluk_fact.o mld_ziluk_fact.o mld_dilut_fact.o mld_zilut_fact.o \ $(MPFOBJS) -OUTEROBJS=mld_dprecbld.o mld_dprecfree.o mld_dprecset.o mld_dprecinit.o\ +OUTEROBJS=mld_sprecbld.o mld_sprecfree.o mld_sprecset.o mld_sprecinit.o\ + mld_sprec_aply.o \ + mld_dprecbld.o mld_dprecfree.o mld_dprecset.o mld_dprecinit.o\ mld_dprec_aply.o \ + mld_cprecbld.o mld_cprecfree.o mld_cprecset.o mld_cprecinit.o\ + mld_cprec_aply.o \ mld_zprecbld.o mld_zprecfree.o mld_zprecset.o mld_zprecinit.o \ mld_zprec_aply.o F90OBJS=$(OUTEROBJS) $(INNEROBJS) -COBJS=mld_dslu_interface.o mld_dumf_interface.o mld_zslu_interface.o mld_zumf_interface.o +COBJS= mld_sslu_interface.o mld_sumf_interface.o \ + mld_dslu_interface.o mld_dumf_interface.o \ + mld_cslu_interface.o mld_cumf_interface.o \ + mld_zslu_interface.o mld_zumf_interface.o OBJS=$(F90OBJS) $(COBJS) $(MPFOBJS) $(MPCOBJS) $(MODOBJS) LIBMOD=mld_prec_mod$(.mod) diff --git a/mlprec/mld_basep_bld_mod.f90 b/mlprec/mld_basep_bld_mod.f90 index f7db4810..4f868a35 100644 --- a/mlprec/mld_basep_bld_mod.f90 +++ b/mlprec/mld_basep_bld_mod.f90 @@ -43,6 +43,15 @@ ! module mld_basep_bld_mod interface mld_baseprc_bld + subroutine mld_sbaseprc_bld(a,desc_a,p,info,upd) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_sbaseprc_type),intent(inout) :: p + integer, intent(out) :: info + character, intent(in), optional :: upd + end subroutine mld_sbaseprc_bld subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd) use psb_base_mod use mld_prec_type @@ -52,6 +61,15 @@ module mld_basep_bld_mod integer, intent(out) :: info character, intent(in), optional :: upd end subroutine mld_dbaseprc_bld + subroutine mld_cbaseprc_bld(a,desc_a,p,info,upd) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_cbaseprc_type),intent(inout) :: p + integer, intent(out) :: info + character, intent(in), optional :: upd + end subroutine mld_cbaseprc_bld subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd) use psb_base_mod use mld_prec_type @@ -64,6 +82,15 @@ module mld_basep_bld_mod end interface interface mld_as_bld + subroutine mld_sas_bld(a,desc_a,p,upd,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_sbaseprc_type),intent(inout) :: p + character, intent(in) :: upd + integer, intent(out) :: info + end subroutine mld_sas_bld subroutine mld_das_bld(a,desc_a,p,upd,info) use psb_base_mod use mld_prec_type @@ -73,6 +100,15 @@ module mld_basep_bld_mod character, intent(in) :: upd integer, intent(out) :: info end subroutine mld_das_bld + subroutine mld_cas_bld(a,desc_a,p,upd,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_cbaseprc_type),intent(inout) :: p + character, intent(in) :: upd + integer, intent(out) :: info + end subroutine mld_cas_bld subroutine mld_zas_bld(a,desc_a,p,upd,info) use psb_base_mod use mld_prec_type @@ -85,6 +121,14 @@ module mld_basep_bld_mod end interface interface mld_mlprec_bld + subroutine mld_smlprec_bld(a,desc_a,p,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(inout), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_sbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + end subroutine mld_smlprec_bld subroutine mld_dmlprec_bld(a,desc_a,p,info) use psb_base_mod use mld_prec_type @@ -93,6 +137,14 @@ module mld_basep_bld_mod type(mld_dbaseprc_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_dmlprec_bld + subroutine mld_cmlprec_bld(a,desc_a,p,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(inout), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_cbaseprc_type), intent(inout),target :: p + integer, intent(out) :: info + end subroutine mld_cmlprec_bld subroutine mld_zmlprec_bld(a,desc_a,p,info) use psb_base_mod use mld_prec_type @@ -104,6 +156,14 @@ module mld_basep_bld_mod end interface interface mld_diag_bld + subroutine mld_sdiag_bld(a,desc_data,p,info) + use psb_base_mod + use mld_prec_type + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(inout) :: p + end subroutine mld_sdiag_bld subroutine mld_ddiag_bld(a,desc_data,p,info) use psb_base_mod use mld_prec_type @@ -112,6 +172,14 @@ module mld_basep_bld_mod type(psb_desc_type),intent(in) :: desc_data type(mld_dbaseprc_type), intent(inout) :: p end subroutine mld_ddiag_bld + subroutine mld_cdiag_bld(a,desc_data,p,info) + use psb_base_mod + use mld_prec_type + integer, intent(out) :: info + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(inout) :: p + end subroutine mld_cdiag_bld subroutine mld_zdiag_bld(a,desc_data,p,info) use psb_base_mod use mld_prec_type @@ -123,6 +191,15 @@ module mld_basep_bld_mod end interface interface mld_fact_bld + subroutine mld_sfact_bld(a,p,upd,info,blck) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(in), target :: a + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + character, intent(in) :: upd + type(psb_sspmat_type), intent(in), target, optional :: blck + end subroutine mld_sfact_bld subroutine mld_dfact_bld(a,p,upd,info,blck) use psb_base_mod use mld_prec_type @@ -132,6 +209,15 @@ module mld_basep_bld_mod character, intent(in) :: upd type(psb_dspmat_type), intent(in), target, optional :: blck end subroutine mld_dfact_bld + subroutine mld_cfact_bld(a,p,upd,info,blck) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(in), target :: a + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + character, intent(in) :: upd + type(psb_cspmat_type), intent(in), target, optional :: blck + end subroutine mld_cfact_bld subroutine mld_zfact_bld(a,p,upd,info,blck) use psb_base_mod use mld_prec_type @@ -144,6 +230,15 @@ module mld_basep_bld_mod end interface interface mld_ilu_bld + subroutine mld_silu_bld(a,p,upd,info,blck) + use psb_base_mod + use mld_prec_type + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), target :: a + type(mld_sbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + type(psb_sspmat_type), intent(in), optional :: blck + end subroutine mld_silu_bld subroutine mld_dilu_bld(a,p,upd,info,blck) use psb_base_mod use mld_prec_type @@ -153,6 +248,15 @@ module mld_basep_bld_mod character, intent(in) :: upd type(psb_dspmat_type), intent(in), optional :: blck end subroutine mld_dilu_bld + subroutine mld_cilu_bld(a,p,upd,info,blck) + use psb_base_mod + use mld_prec_type + integer, intent(out) :: info + type(psb_cspmat_type), intent(in), target :: a + type(mld_cbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + type(psb_cspmat_type), intent(in), optional :: blck + end subroutine mld_cilu_bld subroutine mld_zilu_bld(a,p,upd,info,blck) use psb_base_mod use mld_prec_type @@ -165,6 +269,14 @@ module mld_basep_bld_mod end interface interface mld_sludist_bld + subroutine mld_ssludist_bld(a,desc_a,p,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_ssludist_bld subroutine mld_dsludist_bld(a,desc_a,p,info) use psb_base_mod use mld_prec_type @@ -173,6 +285,14 @@ module mld_basep_bld_mod type(mld_dbaseprc_type), intent(inout) :: p integer, intent(out) :: info end subroutine mld_dsludist_bld + subroutine mld_csludist_bld(a,desc_a,p,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_csludist_bld subroutine mld_zsludist_bld(a,desc_a,p,info) use psb_base_mod use mld_prec_type @@ -184,6 +304,14 @@ module mld_basep_bld_mod end interface interface mld_slu_bld + subroutine mld_sslu_bld(a,desc_a,p,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_sslu_bld subroutine mld_dslu_bld(a,desc_a,p,info) use psb_base_mod use mld_prec_type @@ -192,6 +320,14 @@ module mld_basep_bld_mod type(mld_dbaseprc_type), intent(inout) :: p integer, intent(out) :: info end subroutine mld_dslu_bld + subroutine mld_cslu_bld(a,desc_a,p,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_cslu_bld subroutine mld_zslu_bld(a,desc_a,p,info) use psb_base_mod use mld_prec_type @@ -203,6 +339,14 @@ module mld_basep_bld_mod end interface interface mld_umf_bld + subroutine mld_sumf_bld(a,desc_a,p,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_sumf_bld subroutine mld_dumf_bld(a,desc_a,p,info) use psb_base_mod use mld_prec_type @@ -219,9 +363,26 @@ module mld_basep_bld_mod type(mld_zbaseprc_type), intent(inout) :: p integer, intent(out) :: info end subroutine mld_zumf_bld + subroutine mld_cumf_bld(a,desc_a,p,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_cumf_bld end interface interface mld_ilu0_fact + subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck) + use psb_base_mod + integer, intent(in) :: ialg + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + end subroutine mld_silu0_fact subroutine mld_dilu0_fact(ialg,a,l,u,d,info,blck) use psb_base_mod integer, intent(in) :: ialg @@ -231,6 +392,15 @@ module mld_basep_bld_mod type(psb_dspmat_type),intent(in), optional, target :: blck real(psb_dpk_), intent(inout) :: d(:) end subroutine mld_dilu0_fact + subroutine mld_cilu0_fact(ialg,a,l,u,d,info,blck) + use psb_base_mod + integer, intent(in) :: ialg + integer, intent(out) :: info + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + type(psb_cspmat_type),intent(in), optional, target :: blck + complex(psb_spk_), intent(inout) :: d(:) + end subroutine mld_cilu0_fact subroutine mld_zilu0_fact(ialg,a,l,u,d,info,blck) use psb_base_mod integer, intent(in) :: ialg @@ -243,6 +413,15 @@ module mld_basep_bld_mod end interface interface mld_iluk_fact + subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) + use psb_base_mod + integer, intent(in) :: fill_in,ialg + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + end subroutine mld_siluk_fact subroutine mld_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) use psb_base_mod integer, intent(in) :: fill_in,ialg @@ -252,6 +431,15 @@ module mld_basep_bld_mod type(psb_dspmat_type),intent(in), optional, target :: blck real(psb_dpk_), intent(inout) :: d(:) end subroutine mld_diluk_fact + subroutine mld_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) + use psb_base_mod + integer, intent(in) :: fill_in,ialg + integer, intent(out) :: info + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + type(psb_cspmat_type),intent(in), optional, target :: blck + complex(psb_spk_), intent(inout) :: d(:) + end subroutine mld_ciluk_fact subroutine mld_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) use psb_base_mod integer, intent(in) :: fill_in,ialg @@ -264,6 +452,16 @@ module mld_basep_bld_mod end interface interface mld_ilut_fact + subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck) + use psb_base_mod + integer, intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + end subroutine mld_silut_fact subroutine mld_dilut_fact(fill_in,thres,a,l,u,d,info,blck) use psb_base_mod integer, intent(in) :: fill_in @@ -274,6 +472,16 @@ module mld_basep_bld_mod type(psb_dspmat_type),intent(in), optional, target :: blck real(psb_dpk_), intent(inout) :: d(:) end subroutine mld_dilut_fact + subroutine mld_cilut_fact(fill_in,thres,a,l,u,d,info,blck) + use psb_base_mod + integer, intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + integer, intent(out) :: info + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + type(psb_cspmat_type),intent(in), optional, target :: blck + complex(psb_spk_), intent(inout) :: d(:) + end subroutine mld_cilut_fact subroutine mld_zilut_fact(fill_in,thres,a,l,u,d,info,blck) use psb_base_mod integer, intent(in) :: fill_in diff --git a/mlprec/mld_caggrmap_bld.f90 b/mlprec/mld_caggrmap_bld.f90 new file mode 100644 index 00000000..fdb01385 --- /dev/null +++ b/mlprec/mld_caggrmap_bld.f90 @@ -0,0 +1,391 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_caggrmap_bld.f90 +! +! Subroutine: mld_caggrmap_bld +! Version: complex +! +! This routine builds a mapping from the row indices of the fine-level matrix +! to the row indices of the coarse-level matrix, according to a decoupled +! aggregation algorithm. This mapping will be used by mld_aggrmat_asb to +! build the coarse-level matrix. +! +! The aggregation algorithm is a parallel version of that described in +! M. Brezina and P. Vanek, A black-box iterative solver based on a +! two-level Schwarz method, Computing, 63 (1999), 233-263. +! For more details see +! P. D'Ambra, D. di Serafino and S. Filippone, On the development of +! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math. +! 57 (2007), 1181-1196. +! +! +! Arguments: +! aggr_type - integer, input. +! The scalar used to identify the aggregation algorithm. +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! info - integer, output. +! Error code. +! +subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_caggrmap_bld + + implicit none + +! Arguments + integer, intent(in) :: aggr_type + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in) :: desc_a + integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) + integer, intent(out) :: info + +! Local variables + integer, allocatable :: ils(:), neigh(:) + integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m + type(psb_cspmat_type), target :: atmp, atrans + type(psb_cspmat_type), pointer :: apnt + + logical :: recovery + integer :: debug_level, debug_unit + integer :: ictxt,np,me,err_act + integer :: nrow, ncol, n_ne + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + name = 'mld_aggrmap_bld' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ! + ! Note. At the time being we are ignoring aggr_type so + ! that we only have decoupled aggregation. This might + ! change in the future. + ! + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + select case (aggr_type) + case (mld_dec_aggr_,mld_sym_dec_aggr_) + + nr = a%m + allocate(ilaggr(nr),neigh(nr),stat=info) + if(info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*nr,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + do i=1, nr + ilaggr(i) = -(nr+1) + end do + if (aggr_type == mld_dec_aggr_) then + apnt => a + else + call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,& + & rscale=.false.,cscale=.false.) + atmp%m=nr + atmp%k=nr + if (info == 0) call psb_transp(atmp,atrans,fmt='COO') + if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.) + atmp%m=nr + atmp%k=nr + if (info == 0) call psb_sp_free(atrans,info) + if (info == 0) call psb_ipcoo2csr(atmp,info) + apnt => atmp + if (info/=0) then + info=4001 + call psb_errpush(info,name,a_err='init apnt') + goto 9999 + end if + + end if + + + ! Note: -(nr+1) Untouched as yet + ! -i 1<=i<=nr Adjacent to aggregate i + ! i 1<=i<=nr Belonging to aggregate i + + ! + ! Phase one: group nodes together. + ! Very simple minded strategy. + ! + naggr = 0 + nlp = 0 + do + icnt = 0 + do i=1, nr + if (ilaggr(i) == -(nr+1)) then + ! + ! 1. Untouched nodes are marked >0 together + ! with their neighbours + ! + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + + call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) + if (info/=0) then + info=4010 + call psb_errpush(info,name,a_err='psb_neigh') + goto 9999 + end if + do k=1, n_ne + j = neigh(k) + if ((1<=j).and.(j<=nr)) then + ilaggr(j) = naggr + endif + enddo + ! + ! 2. Untouched neighbours of these nodes are marked <0. + ! + call psb_neigh(apnt,i,neigh,n_ne,info,lev=2) + if (info/=0) then + info=4010 + call psb_errpush(info,name,a_err='psb_neigh') + goto 9999 + end if + + do n = 1, n_ne + m = neigh(n) + if ((1<=m).and.(m<=nr)) then + if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr + endif + enddo + endif + enddo + nlp = nlp + 1 + if (icnt == 0) exit + enddo + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & ' Check 1:',count(ilaggr == -(nr+1)),& + & (a%ia1(i),i=a%ia2(1),a%ia2(2)-1) + end if + + ! + ! Phase two: sweep over leftovers. + ! + allocate(ils(naggr+10),stat=info) + if(info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + do i=1, size(ils) + ils(i) = 0 + end do + do i=1, nr + n = ilaggr(i) + if (n>0) then + if (n>naggr) then + info=4001 + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') + goto 9999 + else + ils(n) = ils(n) + 1 + end if + + end if + end do + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 1: number of aggregates ',naggr + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 1: nodes aggregated ',sum(ils) + end if + + recovery=.false. + do i=1, nr + if (ilaggr(i) < 0) then + ! + ! Now some silly rule to break ties: + ! Group with smallest adjacent aggregate. + ! + isz = nr+1 + ia = -1 + + call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) + if (info/=0) then + info=4010 + call psb_errpush(info,name,a_err='psb_neigh') + goto 9999 + end if + + do j=1, n_ne + k = neigh(j) + if ((1<=k).and.(k<=nr)) then + n = ilaggr(k) + if (n>0) then + if (n>naggr) then + info=4001 + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') + goto 9999 + end if + + if (ils(n) < isz) then + ia = n + isz = ils(n) + endif + endif + endif + enddo + if (ia == -1) then + if (ilaggr(i) > -(nr+1)) then + ilaggr(i) = abs(ilaggr(i)) + if (ilaggr(I)>naggr) then + info=4001 + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 3 ?') + goto 9999 + end if + ils(ilaggr(i)) = ils(ilaggr(i)) + 1 + ! + ! This might happen if the pattern is non symmetric. + ! Need a better handling. + ! + recovery = .true. + else + info=4001 + call psb_errpush(info,name,a_err='Unrecoverable error !!') + goto 9999 + endif + else + ilaggr(i) = ia + if (ia>naggr) then + info=4001 + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ') + goto 9999 + end if + ils(ia) = ils(ia) + 1 + endif + end if + enddo + if (debug_level >= psb_debug_outer_) then + if (recovery) then + write(debug_unit,*) me,' ',trim(name),& + & 'Had to recover from strange situation in loc_aggregate.' + write(debug_unit,*) me,' ',trim(name),& + & 'Perhaps an unsymmetric pattern?' + endif + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 2: number of aggregates ',naggr,sum(ils) + do i=1, naggr + write(debug_unit,*) me,' ',trim(name),& + & 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i) + enddo + write(debug_unit,*) me,' ',trim(name),& + & maxval(ils(1:naggr)) + write(debug_unit,*) me,' ',trim(name),& + & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' + end if + + if (count(ilaggr<0) >0) then + info=4001 + call psb_errpush(info,name,a_err='Fatal error: some leftovers') + goto 9999 + endif + + deallocate(ils,neigh,stat=info) + if (info/=0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(ncol,ilaggr,info) + if (info/=0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(nlaggr(np),stat=info) + if (info/=0) then + info=4025 + call psb_errpush(info,name,i_err=(/np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + nlaggr(:) = 0 + nlaggr(me+1) = naggr + call psb_sum(ictxt,nlaggr(1:np)) + + if (aggr_type == mld_sym_dec_aggr_) then + call psb_sp_free(atmp,info) + end if + + case default + + info = -1 + call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_caggrmap_bld diff --git a/mlprec/mld_caggrmat_asb.f90 b/mlprec/mld_caggrmat_asb.f90 new file mode 100644 index 00000000..09e2e21a --- /dev/null +++ b/mlprec/mld_caggrmat_asb.f90 @@ -0,0 +1,160 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_caggrmat_asb.f90 +! +! Subroutine: mld_caggrmat_asb +! Version: complex +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using a Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! A mapping from the nodes of the adjacency graph of A to the nodes of the +! adjacency graph of A_C has been computed by the mld_aggrmap_bld subroutine. +! The prolongator P_C is built here from this mapping, according to the +! value of p%iprcparm(mld_aggr_kind_), specified by the user through +! mld_dprecinit and mld_dprecset. +! +! Currently three different prolongators are implemented, corresponding to +! three aggregation algorithms: +! 1. raw aggregation, +! 2. smoothed aggregation, +! 3. "bizarre" aggregation. +! 1. The raw aggregation uses as prolongator the piecewise constant interpolation +! operator corresponding to the fine-to-coarse level mapping built by +! mld_aggrmap_bld. This is called tentative prolongator. +! 2. The smoothed aggregation uses as prolongator the operator obtained by applying +! a damped Jacobi smoother to the tentative prolongator. +! 3. The "bizarre" aggregation uses a prolongator proposed by the authors of MLD2P4. +! This prolongator still requires a deep analysis and testing and its use is +! not recommended. +! +! For more details see +! M. Brezina and P. Vanek, A black-box iterative solver based on a two-level +! Schwarz method, Computing, 63 (1999), 233-263. +! P. D'Ambra, D. di Serafino and S. Filippone, On the development of PSBLAS-based +! parallel two-level Schwarz preconditioners, Appl. Num. Math., 57 (2007), +! 1181-1196. +! +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! ac - type(psb_cspmat_type), output. +! The sparse matrix structure containing the local part of +! the coarse-level matrix. +! desc_ac - type(psb_desc_type), output. +! The communication descriptor of the coarse-level matrix. +! p - type(mld_cbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_caggrmat_asb(a,desc_a,ac,desc_ac,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_caggrmat_asb + + implicit none + +! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_cbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + +! Local variables + integer :: ictxt,np,me, err_act, icomm + character(len=20) :: name + + name='mld_aggrmat_asb' + if(psb_get_errstatus().ne.0) return + info=0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + + call psb_info(ictxt, me, np) + + select case (p%iprcparm(mld_aggr_kind_)) + case (mld_no_smooth_) + + call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_aggrmat_raw_asb') + goto 9999 + end if + + case(mld_smooth_prol_,mld_biz_prol_) + + call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_aggrmat_smth_asb') + goto 9999 + end if + + case default + + call psb_errpush(4001,name,a_err='Invalid aggr kind') + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_caggrmat_asb diff --git a/mlprec/mld_caggrmat_raw_asb.F90 b/mlprec/mld_caggrmat_raw_asb.F90 new file mode 100644 index 00000000..8ff8790e --- /dev/null +++ b/mlprec/mld_caggrmat_raw_asb.F90 @@ -0,0 +1,284 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_caggrmat_raw_asb.F90 +! +! Subroutine: mld_caggrmat_raw_asb +! Version: complex +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using a Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is the piecewise constant interpolation operator corresponding +! the fine-to-coarse level mapping built by mld_aggrmap_bld. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%iprcparm(mld_coarse_mat_), +! specified by the user through mld_dprecinit and mld_dprecset. +! +! For details see +! P. D'Ambra, D. di Serafino and S. Filippone, On the development of +! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math., +! 57 (2007), 1181-1196. +! +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! ac - type(psb_cspmat_type), output. +! The sparse matrix structure containing the local part of +! the coarse-level matrix. +! desc_ac - type(psb_desc_type), output. +! The communication descriptor of the coarse-level matrix. +! p - type(mld_cbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_caggrmat_raw_asb + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + +! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_cbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + +! Local variables + integer ::ictxt,np,me, err_act, icomm + character(len=20) :: name + type(psb_cspmat_type) :: b + integer, pointer :: nzbr(:), idisp(:) + type(psb_cspmat_type), pointer :: am1,am2 + integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + & naggr, nzt,naggrm1, i + + name='mld_aggrmat_raw_asb' + if(psb_get_errstatus().ne.0) return + info=0 + call psb_erractionsave(err_act) + + call psb_nullify_sp(b) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt, me, np) + nglob = psb_cd_get_global_rows(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + + am2 => p%av(mld_sm_pr_t_) + am1 => p%av(mld_sm_pr_) + call psb_nullify_sp(am1) + call psb_nullify_sp(am2) + + + naggr = p%nlaggr(me+1) + ntaggr = sum(p%nlaggr) + allocate(nzbr(np), idisp(np),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + naggrm1=sum(p%nlaggr(1:me)) + + if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then + do i=1, nrow + p%mlia(i) = p%mlia(i) + naggrm1 + end do + call psb_halo(p%mlia,desc_a,info) + end if + + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_halo') + goto 9999 + end if + + if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then + call psb_sp_all(ncol,ntaggr,am1,ncol,info) + else + call psb_sp_all(ncol,naggr,am1,ncol,info) + end if + + if (info /= 0) then + call psb_errpush(4010,name,a_err='spall') + goto 9999 + end if + + do i=1,nrow + am1%aspk(i) = cone + am1%ia1(i) = i + am1%ia2(i) = p%mlia(i) + end do + am1%infoa(psb_nnz_) = nrow + + call psb_spcnv(am1,info,afmt='csr',dupl=psb_dupl_add_) + call psb_transp(am1,am2) + + + call psb_sp_clip(a,b,info,jmax=nrow) + if(info /= 0) then + call psb_errpush(4010,name,a_err='spclip') + goto 9999 + end if + ! Out from sp_clip is always in COO, but just in case.. + if (psb_tolower(b%fida) /= 'coo') then + call psb_errpush(4010,name,a_err='spclip NOT COO') + goto 9999 + end if + + nzt = psb_sp_get_nnzeros(b) + do i=1, nzt + b%ia1(i) = p%mlia(b%ia1(i)) + b%ia2(i) = p%mlia(b%ia2(i)) + enddo + b%m = naggr + b%k = naggr + ! This is to minimize data exchange + call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) + + if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then + + call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdall') + goto 9999 + end if + + nzbr(:) = 0 + nzbr(me+1) = nzt + call psb_sum(ictxt,nzbr(1:np)) + nzac = sum(nzbr) + + call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_all') + goto 9999 + end if + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + + call mpi_allgatherv(b%aspk,ndx,mpi_complex,ac%aspk,nzbr,idisp,& + & mpi_complex,icomm,info) + call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& + & mpi_integer,icomm,info) + call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& + & mpi_integer,icomm,info) + if(info /= 0) then + info=-1 + call psb_errpush(info,name) + goto 9999 + end if + + ac%m = ntaggr + ac%k = ntaggr + ac%infoa(psb_nnz_) = nzac + ac%fida='COO' + ac%descra='GUN' + call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_free') + goto 9999 + end if + + else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then + + call psb_cdall(ictxt,desc_ac,info,nl=naggr) + if (info == 0) call psb_cdasb(desc_ac,info) + if (info == 0) call psb_sp_clone(b,ac,info) + if(info /= 0) then + call psb_errpush(4001,name,a_err='Build ac, desc_ac') + goto 9999 + end if + call psb_sp_free(b,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_free') + goto 9999 + end if + + else + info = 4001 + call psb_errpush(4001,name,a_err='invalid mld_coarse_mat_') + goto 9999 + end if + + deallocate(nzbr,idisp) + + call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4010,name,a_err='ipcoo2csr') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_caggrmat_raw_asb diff --git a/mlprec/mld_caggrmat_smth_asb.F90 b/mlprec/mld_caggrmat_smth_asb.F90 new file mode 100644 index 00000000..47f0c952 --- /dev/null +++ b/mlprec/mld_caggrmat_smth_asb.F90 @@ -0,0 +1,666 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_caggrmat_smth_asb.F90 +! +! Subroutine: mld_caggrmat_smth_asb +! Version: complex +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using a Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! The prolongator P_C is built according to a smoothed aggregation algorithm, +! i.e. it is obtained by applying a damped Jacobi smoother to the piecewise +! constant interpolation operator P corresponding to the fine-to-coarse level +! mapping built by the mld_aggrmap_bld subroutine: +! +! P_C = (I - omega*D^(-1)A) * P, +! +! where D is the diagonal matrix with main diagonal equal to the main diagonal +! of A, and omega is a suitable smoothing parameter. An estimate of the spectral +! radius of D^(-1)A, to be used in the computation of omega, is provided, +! according to the value of p%iprcparm(mld_aggr_eig_), specified by the user +! through mld_dprecinit and mld_dprecset. +! +! This routine can also build A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%iprcparm(mld_coarse_mat_), +! specified by the user through mld_dprecinit and mld_dprecset. +! +! For more details see +! M. Brezina and P. Vanek, A black-box iterative solver based on a +! two-level Schwarz method, Computing, 63 (1999), 233-263. +! P. D'Ambra, D. di Serafino and S. Filippone, On the development of +! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math. +! 57 (2007), 1181-1196. +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! ac - type(psb_cspmat_type), output. +! The sparse matrix structure containing the local part of +! the coarse-level matrix. +! desc_ac - type(psb_desc_type), output. +! The communication descriptor of the coarse-level matrix. +! p - type(mld_cbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_caggrmat_smth_asb + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + +! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_cbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + +! Local variables + type(psb_cspmat_type) :: b + integer, pointer :: nzbr(:), idisp(:) + integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k + integer ::ictxt,np,me, err_act, icomm + character(len=20) :: name + type(psb_cspmat_type), pointer :: am1,am2 + type(psb_cspmat_type) :: am3,am4 + logical :: ml_global_nmb + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_spk_) :: omega, anorm, tmp, dg + + name='mld_aggrmat_smth_asb' + if(psb_get_errstatus().ne.0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + + call psb_nullify_sp(b) + call psb_nullify_sp(am3) + call psb_nullify_sp(am4) + + am2 => p%av(mld_sm_pr_t_) + am1 => p%av(mld_sm_pr_) + call psb_nullify_sp(am1) + call psb_nullify_sp(am2) + + nglob = psb_cd_get_global_rows(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + naggr = p%nlaggr(me+1) + ntaggr = sum(p%nlaggr) + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + naggrm1 = sum(p%nlaggr(1:me)) + naggrp1 = sum(p%nlaggr(1:me+1)) + ml_global_nmb = ( (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_).or.& + & ( (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_).and.& + & (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_)) ) + + if (ml_global_nmb) then + p%mlia(1:nrow) = p%mlia(1:nrow) + naggrm1 + call psb_halo(p%mlia,desc_a,info) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_halo') + goto 9999 + end if + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(p%dorig(nrow),stat=info) + + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + ! Get diagonal D + call psb_sp_getdiag(a,p%dorig,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_getdiag') + goto 9999 + end if + + do i=1,size(p%dorig) + if (p%dorig(i) /= czero) then + p%dorig(i) = cone / p%dorig(i) + else + p%dorig(i) = cone + end if + end do + + ! 1. Allocate Ptilde in sparse matrix form + am4%fida='COO' + am4%m=ncol + if (ml_global_nmb) then + am4%k=ntaggr + call psb_sp_all(ncol,ntaggr,am4,ncol,info) + else + am4%k=naggr + call psb_sp_all(ncol,naggr,am4,ncol,info) + endif + + if (info /= 0) then + call psb_errpush(4010,name,a_err='spall') + goto 9999 + end if + + if (ml_global_nmb) then + do i=1,ncol + am4%aspk(i) = cone + am4%ia1(i) = i + am4%ia2(i) = p%mlia(i) + end do + am4%infoa(psb_nnz_) = ncol + else + do i=1,nrow + am4%aspk(i) = cone + am4%ia1(i) = i + am4%ia2(i) = p%mlia(i) + end do + am4%infoa(psb_nnz_) = nrow + endif + + + call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_) + if (info==0) call psb_spcnv(a,am3,info,afmt='csr',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='spcnv') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies done.' + + ! + ! WARNING: the cycles below assume that AM3 does have + ! its diagonal elements stored explicitly!!! + ! Should we switch to something safer? + ! + call psb_sp_scal(am3,p%dorig,info) + if (info /= 0) goto 9999 + + if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then + + if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then + + ! + ! This only works with CSR. + ! + if (psb_toupper(am3%fida)=='CSR') then + anorm = dzero + dg = done + do i=1,am3%m + tmp = dzero + do j=am3%ia2(i),am3%ia2(i+1)-1 + if (am3%ia1(j) <= am3%m) then + tmp = tmp + abs(am3%aspk(j)) + endif + if (am3%ia1(j) == i ) then + dg = abs(am3%aspk(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + else + info = 4001 + endif + else + anorm = psb_spnrmi(am3,desc_a,info) + endif + if (info /= 0) then + call psb_errpush(4001,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + p%rprcparm(mld_aggr_damp_) = omega + + else if (p%iprcparm(mld_aggr_eig_) == mld_user_choice_) then + + omega = p%rprcparm(mld_aggr_damp_) + + else if (p%iprcparm(mld_aggr_eig_) /= mld_user_choice_) then + info = 4001 + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + + if (psb_toupper(am3%fida)=='CSR') then + do i=1,am3%m + do j=am3%ia2(i),am3%ia2(i+1)-1 + if (am3%ia1(j) == i) then + am3%aspk(j) = cone - omega*am3%aspk(j) + else + am3%aspk(j) = - omega*am3%aspk(j) + end if + end do + end do + else + call psb_errpush(4001,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! am1 = (i-wDA)Ptilde + ! Doing it this way means to consider diag(Ai) + ! + ! + call psb_symbmm(am3,am4,am1,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(am3,am4,am1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + call psb_sp_free(am4,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_free') + goto 9999 + end if + + if (ml_global_nmb) then + ! + ! Now we have to gather the halo of am1, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(am1,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == 0) call psb_rwextd(ncol,am1,info,b=am4) + if (info == 0) call psb_sp_free(am4,info) + else + call psb_rwextd(ncol,am1,info) + endif + if(info /= 0) then + call psb_errpush(4001,name,a_err='Halo of am1') + goto 9999 + end if + + call psb_symbmm(a,am1,am3,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,am1,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2' + + if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then + call psb_transp(am1,am2,fmt='COO') + nzl = am2%infoa(psb_nnz_) + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in p%mlia(:) + ! + do k=1, nzl + if ((naggrm1 < am2%ia1(k)) .and.(am2%ia1(k) <= naggrp1)) then + i = i+1 + am2%aspk(i) = am2%aspk(k) + am2%ia1(i) = am2%ia1(k) + am2%ia2(i) = am2%ia2(k) + end if + end do + am2%infoa(psb_nnz_) = i + call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) + if (info /=0) then + call psb_errpush(4010,name,a_err='spcnv am2') + goto 9999 + end if + else + call psb_transp(am1,am2) + endif + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then + ! am2 = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == 0) call psb_rwextd(ncol,am3,info,b=am4) + if (info == 0) call psb_sp_free(am4,info) + else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then + call psb_rwextd(ncol,am3,info) + endif + if(info /= 0) then + call psb_errpush(4001,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(am2,am3,b,info) + if (info == 0) call psb_numbmm(am2,am3,b) + if (info == 0) call psb_sp_free(am3,info) + if (info == 0) call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Build b = am2 x am3') + goto 9999 + end if + + + + select case(p%iprcparm(mld_aggr_kind_)) + + case(mld_smooth_prol_) + + select case(p%iprcparm(mld_coarse_mat_)) + + case(mld_distr_mat_) + + call psb_sp_clone(b,ac,info) + nzac = ac%infoa(psb_nnz_) + nzl = ac%infoa(psb_nnz_) + if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1)) + if (info == 0) call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info) + if (info == 0) call psb_cdasb(desc_ac,info) + if (info == 0) call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I') + if (info == 0) call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I') + if (info /= 0) then + call psb_errpush(4001,name,a_err='Creating desc_ac and converting ac') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + + + ac%m=desc_ac%matrix_data(psb_n_row_) + ac%k=desc_ac%matrix_data(psb_n_col_) + ac%fida='COO' + ac%descra='GUN' + + call psb_sp_free(b,info) + if (info == 0) deallocate(nzbr,idisp,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + if (np>1) then + nzl = psb_sp_get_nnzeros(am1) + call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I') + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_glob_to_loc') + goto 9999 + end if + endif + am1%k=desc_ac%matrix_data(psb_n_col_) + + if (np>1) then + call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_) + nzl = am2%infoa(psb_nnz_) + if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I') + if (info == 0) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4001,name,a_err='Converting am2 to local') + goto 9999 + end if + end if + am2%m=desc_ac%matrix_data(psb_n_col_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) + nzbr(:) = 0 + nzbr(me+1) = b%infoa(psb_nnz_) + + call psb_sum(ictxt,nzbr(1:np)) + nzac = sum(nzbr) + if (info == 0) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) + if (info /= 0) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + + call mpi_allgatherv(b%aspk,ndx,mpi_complex,ac%aspk,nzbr,idisp,& + & mpi_complex,icomm,info) + if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& + & mpi_integer,icomm,info) + + if (info /= 0) then + call psb_errpush(4001,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + + ac%m = ntaggr + ac%k = ntaggr + ac%infoa(psb_nnz_) = nzac + ac%fida='COO' + ac%descra='GUN' + call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) + if(info /= 0) goto 9999 + call psb_sp_free(b,info) + if(info /= 0) goto 9999 + + deallocate(nzbr,idisp,stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 + end select + + + case(mld_biz_prol_) + + select case(p%iprcparm(mld_coarse_mat_)) + + case(mld_distr_mat_) + + call psb_sp_clone(b,ac,info) + if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=naggr) + if (info == 0) call psb_cdasb(desc_ac,info) + if (info == 0) call psb_sp_free(b,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Build desc_ac, ac') + goto 9999 + end if + + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdall') + goto 9999 + end if + + nzbr(:) = 0 + nzbr(me+1) = b%infoa(psb_nnz_) + call psb_sum(ictxt,nzbr(1:np)) + nzac = sum(nzbr) + call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_sp_all') + goto 9999 + end if + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + + call mpi_allgatherv(b%aspk,ndx,mpi_complex,ac%aspk,nzbr,idisp,& + & mpi_complex,icomm,info) + if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + + + ac%m = ntaggr + ac%k = ntaggr + ac%infoa(psb_nnz_) = nzac + ac%fida='COO' + ac%descra='GUN' + call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4010,name,a_err='spcnv') + goto 9999 + end if + call psb_sp_free(b,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 + end select + + deallocate(nzbr,idisp,stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') + goto 9999 + + end select + + call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4010,name,a_err='spcnv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_caggrmat_smth_asb diff --git a/mlprec/mld_cas_aply.f90 b/mlprec/mld_cas_aply.f90 new file mode 100644 index 00000000..7fe99971 --- /dev/null +++ b/mlprec/mld_cas_aply.f90 @@ -0,0 +1,407 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cas_aply.f90 +! +! Subroutine: mld_cas_aply +! Version: real +! +! This routine applies the Additive Schwarz preconditioner by computing +! +! Y = beta*Y + alpha*op(K^(-1))*X, +! where +! - K is the base preconditioner, stored in prec, +! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! +! Arguments: +! alpha - real(psb_spk_), input. +! The scalar alpha. +! prec - type(mld_dbaseprc_type), input. +! The base preconditioner data structure containing the local part +! of the preconditioner K. +! x - real(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - real(psb_spk_), input. +! The scalar beta. +! y - real(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(K^(-1)) = K^(-1); +! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). +! work - real(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +subroutine mld_cas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cas_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col, int_err(5), nrow_d + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,isz, err_act + character(len=20) :: name, ch_err + character :: trans_ + + name='mld_cas_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_data) + + call psb_info(ictxt, me, np) + + trans_ = psb_toupper(trans) + + select case(prec%iprcparm(mld_prec_type_)) + + case(mld_bjac_) + + call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) + if (info /= 0) then + info=4010 + ch_err='mld_sub_aply' + goto 9999 + end if + + case(mld_as_) + ! + ! Additive Schwarz preconditioner + ! + + if ((prec%iprcparm(mld_n_ovr_)==0).or.(np==1)) then + ! + ! Shortcut: this fixes performance for RAS(0) == BJA + ! + call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) + if(info /= 0) then + info=4010 + ch_err='mld_sub_aply' + goto 9999 + end if + + else + ! + ! Overlap > 0 + ! + + n_row = psb_cd_get_local_rows(prec%desc_data) + n_col = psb_cd_get_local_cols(prec%desc_data) + nrow_d = psb_cd_get_local_rows(desc_data) + isz=max(n_row,N_COL) + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + endif + + tx(1:nrow_d) = x(1:nrow_d) + tx(nrow_d+1:isz) = dzero + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx==x) + ! + if (prec%iprcparm(mld_sub_restr_)==psb_halo_) then + call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /=0) then + info=4010 + ch_err='psb_halo' + goto 9999 + end if + else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then + call psb_errpush(4001,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + ! + ! If required, reorder tx according to the row/column permutation of the + ! local extended matrix, stored into the permutation vector prec%perm + ! + if (prec%iprcparm(mld_sub_ren_)>0) then + call psb_gelp('n',prec%perm,tx,info) + if(info /=0) then + info=4010 + ch_err='psb_gelp' + goto 9999 + end if + endif + + ! + ! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the + ! block-Jacobi solver can be applied at the coarsest level of a multilevel + ! preconditioner). The resulting vector is ty. + ! + call mld_sub_aply(cone,prec,tx,czero,ty,prec%desc_data,trans_,aux,info) + if(info /= 0) then + info=4010 + ch_err='mld_sub_aply' + goto 9999 + end if + + ! + ! Apply to ty the inverse permutation of prec%perm + ! + if (prec%iprcparm(mld_sub_ren_)>0) then + call psb_gelp('n',prec%invperm,ty,info) + if(info /= 0) then + info=4010 + ch_err='psb_gelp' + goto 9999 + end if + endif + + select case (prec%iprcparm(mld_sub_prol_)) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,prec%desc_data,info,& + ! & update=prec%iprcparm(mld_sub_prol_),work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,prec%desc_data,info,& + & update=prec%iprcparm(mld_sub_prol_),work=aux) + if(info /=0) then + info=4010 + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(4001,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (prec%iprcparm(mld_sub_prol_)) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /=0) then + info=4010 + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,prec%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /=0) then + info=4010 + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /=0) then + info=4010 + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(4001,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + ! + ! If required, reorder tx according to the row/column permutation of the + ! local extended matrix, stored into the permutation vector prec%perm + ! + if (prec%iprcparm(mld_sub_ren_)>0) then + call psb_gelp('n',prec%perm,tx,info) + if(info /=0) then + info=4010 + ch_err='psb_gelp' + goto 9999 + end if + endif + + ! + ! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the + ! block-Jacobi solver can be applied at the coarsest level of a multilevel + ! preconditioner). The resulting vector is ty. + ! + call mld_sub_aply(cone,prec,tx,czero,ty,prec%desc_data,trans_,aux,info) + if(info /= 0) then + info=4010 + ch_err='mld_sub_aply' + goto 9999 + end if + + ! + ! Apply to ty the inverse permutation of prec%perm + ! + if (prec%iprcparm(mld_sub_ren_)>0) then + call psb_gelp('n',prec%invperm,ty,info) + if(info /= 0) then + info=4010 + ch_err='psb_gelp' + goto 9999 + end if + endif + + ! + ! With transpose, we have to do it here + ! + if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then + call psb_ovrl(ty,prec%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /=0) then + info=4010 + ch_err='psb_ovrl' + goto 9999 + end if + else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then + call psb_errpush(4001,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=40 + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + ! + ! Compute y = beta*y + alpha*ty (ty==K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + end if + + case default + + call psb_errpush(4001,name,a_err='Invalid mld_prec_type_') + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cas_aply + diff --git a/mlprec/mld_cas_bld.f90 b/mlprec/mld_cas_bld.f90 new file mode 100644 index 00000000..c6be9cd6 --- /dev/null +++ b/mlprec/mld_cas_bld.f90 @@ -0,0 +1,287 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cas_bld.f90 +! +! Subroutine: mld_cas_bld +! Version: complex +! +! This routine builds Additive Schwarz (AS) preconditioners. If the AS +! preconditioner is actually the block-Jacobi one, the routine makes only a +! copy of the descriptor of the original matrix and then calls mld_fact_bld +! to perform an LU or ILU factorization of the diagonal blocks of the +! distributed matrix. +! +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of the +! matrix to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the sparse matrix a. +! p - type(mld_cbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the local +! part of the preconditioner or solver to be built. +! upd - character, input. +! If upd='F' then the preconditioner is built from scratch; +! if upd=T' then the matrix to be preconditioned has the same +! sparsity pattern of a matrix that has been previously +! preconditioned, hence some information is reused in building +! the new preconditioner. +! info - integer, output. +! Error code. +! +subroutine mld_cas_bld(a,desc_a,p,upd,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cas_bld + + Implicit None + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + type(mld_cbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + integer, intent(out) :: info + + ! Local variables + integer :: ptype,novr + integer :: icomm + Integer :: np,me,nnzero,ictxt, int_err(5),& + & tot_recv, n_row,n_col,nhalo, err_act, data_ + type(psb_cspmat_type) :: blck + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='mld_as_bld' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + If (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' start ', upd + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + + Call psb_info(ictxt, me, np) + + tot_recv=0 + + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + nnzero = psb_sp_get_nnzeros(a) + nhalo = n_col-n_row + ptype = p%iprcparm(mld_prec_type_) + novr = p%iprcparm(mld_n_ovr_) + + select case (ptype) + + case(mld_bjac_) + ! + ! Block Jacobi + ! + data_ = psb_no_comm_ + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling desccpy' + if (upd == 'F') then + call psb_cdcpy(desc_a,p%desc_data,info) + If(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done cdcpy' + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Early return: P>=3 N_OVR=0' + endif + call psb_sp_all(0,0,blck,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + blck%fida = 'COO' + blck%infoa(psb_nnz_) = 0 + + call mld_fact_bld(a,p,upd,info,blck=blck) + + if (info /= 0) then + info=4010 + ch_err='mld_fact_bld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + case(mld_as_) + ! + ! Additive Schwarz + ! + if (novr < 0) then + info=3 + int_err(1)=novr + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + if ((novr == 0).or.(np==1)) then + ! + ! Actually, this is just block Jacobi + ! + data_ = psb_no_comm_ + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling desccpy' + if (upd == 'F') then + call psb_cdcpy(desc_a,p%desc_data,info) + If(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done cdcpy' + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Early return: P>=3 N_OVR=0' + endif + call psb_sp_all(0,0,blck,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + blck%fida = 'COO' + blck%infoa(psb_nnz_) = 0 + + else + + If (upd == 'F') Then + ! + ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). + ! This is done by psb_cdbldext (interface to psb_cdovr), which is + ! independent of CSR, and has been placed in the tools directory + ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it + ! might be used independently of the AS preconditioner, to build + ! a descriptor for an extended stencil in a PDE solver. + ! + call psb_cdbldext(a,desc_a,novr,p%desc_data,info,extype=psb_ovt_asov_) + if(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' From cdbldext _:',p%desc_data%matrix_data(psb_n_row_),& + & p%desc_data%matrix_data(psb_n_col_) + + if (info /= 0) then + info=4010 + ch_err='psb_cdbldext' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + Endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Before sphalo ',blck%fida,blck%m,psb_nnz_,blck%infoa(psb_nnz_) + + ! + ! Retrieve the remote sparse matrix rows required for the AS extended + ! matrix + data_ = psb_comm_ext_ + Call psb_sphalo(a,p%desc_data,blck,info,data=data_,rowscale=.true.) + + if (info /= 0) then + info=4010 + ch_err='psb_sphalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'After psb_sphalo ',& + & blck%fida,blck%m,psb_nnz_,blck%infoa(psb_nnz_) + + End if + + + call mld_fact_bld(a,p,upd,info,blck=blck) + + if (info /= 0) then + info=4010 + ch_err='mld_fact_bld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case default + + info=4001 + ch_err='Invalid ptype' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + End select + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),'Done' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + Return + +End Subroutine mld_cas_bld + diff --git a/mlprec/mld_cbaseprec_aply.f90 b/mlprec/mld_cbaseprec_aply.f90 new file mode 100644 index 00000000..7bfa191e --- /dev/null +++ b/mlprec/mld_cbaseprec_aply.f90 @@ -0,0 +1,193 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cbaseprec_aply.f90 +! +! Subroutine: mld_cbaseprec_aply +! Version: complex +! +! This routine applies a base preconditioner by computing +! +! Y = beta*Y + alpha*op(K^(-1))*X, +! where +! - K is the base preconditioner, stored in prec, +! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! The routine is used by mld_dmlprec_aply, to apply the multilevel preconditioners, +! or directly by mld_dprec_aply, to apply the basic one-level preconditioners (diagonal, +! block-Jacobi or additive Schwarz). It also manages the case of no preconditioning. +! +! +! Arguments: +! alpha - complex(psb_spk_), input. +! The scalar alpha. +! prec - type(mld_cbaseprc_type), input. +! The base preconditioner data structure containing the local part +! of the preconditioner K. +! x - complex(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - complex(psb_spk_), input. +! The scalar beta. +! y - complex(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(K^(-1)) = K^(-1); +! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). +! work - real(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +subroutine mld_cbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cbaseprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + complex(psb_spk_), pointer :: ww(:) + integer :: ictxt, np, me, err_act + integer :: n_row, int_err(5) + character(len=20) :: name, ch_err + character :: trans_ + + name='mld_cbaseprec_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_data) + + call psb_info(ictxt, me, np) + + trans_= psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + info=40 + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + select case(prec%iprcparm(mld_prec_type_)) + + case(mld_noprec_) + ! + ! No preconditioner + ! + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + + case(mld_diag_) + ! + ! Diagonal preconditioner + ! + + if (size(work) >= size(x)) then + ww => work + else + allocate(ww(size(x)),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/size(x),0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + end if + + n_row = psb_cd_get_local_rows(desc_data) + if (trans_=='C') then + ww(1:n_row) = x(1:n_row)*conjg(prec%d(1:n_row)) + else + ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) + end if + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + if (size(work) < size(x)) then + deallocate(ww,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Deallocate') + goto 9999 + end if + end if + + case(mld_bjac_,mld_as_) + ! + ! Additive Schwarz preconditioner + ! + call mld_as_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) + if(info /= 0) then + info=4010 + ch_err='mld_as_aply' + goto 9999 + end if + + case default + call psb_errpush(4001,name,a_err='Invalid mld_prec_type_') + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cbaseprec_aply + diff --git a/mlprec/mld_cbaseprec_bld.f90 b/mlprec/mld_cbaseprec_bld.f90 new file mode 100644 index 00000000..2c8ae598 --- /dev/null +++ b/mlprec/mld_cbaseprec_bld.f90 @@ -0,0 +1,217 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cbaseprec_bld.f90 +! +! Subroutine: mld_cbaseprc_bld +! Version: complex +! +! This routine builds a 'base preconditioner' related to a matrix A. +! In a multilevel framework, it is called by mld_mlprec_bld to build the +! base preconditioner at each level. +! +! Details on the base preconditioner to be built are stored in the iprcparm +! field of the preconditioner data structure (for a description of this +! data structure see mld_prec_type.f90). +! +! +! Arguments: +! a - type(psb_cspmat_type). +! The sparse matrix structure containing the local part of the +! matrix A to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_cbaseprec_type), input/output. +! The 'base preconditioner' data structure containing the local +! part of the preconditioner at the selected level. +! info - integer, output. +! Error code. +! upd - character, input, optional. +! If upd='F' then the base preconditioner is built from +! scratch; if upd=T' then the matrix to be preconditioned +! has the same sparsity pattern of a matrix that has been +! previously preconditioned, hence some information is reused +! in building the new preconditioner. +! +subroutine mld_cbaseprc_bld(a,desc_a,p,info,upd) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cbaseprc_bld + + Implicit None + + ! Arguments + type(psb_cspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_cbaseprc_type),intent(inout) :: p + integer, intent(out) :: info + character, intent(in), optional :: upd + + ! Local variables + Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act + character :: iupd + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if (psb_get_errstatus() /= 0) return + name = 'mld_cbaseprc_bld' + info=0 + err=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + if (present(upd)) then + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),'UPD ', upd + if ((psb_toupper(UPD) == 'F').or.(psb_toupper(UPD) == 'T')) then + IUPD=psb_toupper(UPD) + else + IUPD='F' + endif + else + IUPD='F' + endif + + ! + ! Should add check to ensure all procs have the same... + ! + + call mld_check_def(p%iprcparm(mld_prec_type_),'base_prec',& + & mld_diag_,is_legal_base_prec) + + + call psb_nullify_desc(p%desc_data) + + select case(p%iprcparm(mld_prec_type_)) + + case (mld_noprec_) + ! No preconditioner + + ! Do nothing + call psb_cdcpy(desc_a,p%desc_data,info) + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case (mld_diag_) + ! Diagonal preconditioner + + call mld_diag_bld(a,desc_a,p,info) + if(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out of mld_diag_bld' + if(info /= 0) then + info=4010 + ch_err='mld_diag_bld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(mld_bjac_,mld_as_) + ! Additive Schwarz preconditioners/smoothers + + call mld_check_def(p%iprcparm(mld_n_ovr_),'overlap',& + & 0,is_legal_n_ovr) + call mld_check_def(p%iprcparm(mld_sub_restr_),'restriction',& + & psb_halo_,is_legal_restrict) + call mld_check_def(p%iprcparm(mld_sub_prol_),'prolongator',& + & psb_none_,is_legal_prolong) + call mld_check_def(p%iprcparm(mld_sub_ren_),'renumbering',& + & mld_renum_none_,is_legal_renum) + call mld_check_def(p%iprcparm(mld_sub_solve_),'fact',& + & mld_ilu_n_,is_legal_ml_fact) + + ! Set parameters for using SuperLU_dist on the local submatrices + if (p%iprcparm(mld_sub_solve_)==mld_sludist_) then + p%iprcparm(mld_n_ovr_) = 0 + p%iprcparm(mld_smooth_sweeps_) = 1 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': Calling mld_as_bld' + + ! Build the local part of the base preconditioner/smoother + call mld_as_bld(a,desc_a,p,iupd,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='mld_as_bld') + goto 9999 + end if + + case default + + info=4001 + ch_err='Unknown mld_prec_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + end select + + p%base_a => a + p%base_desc => desc_a + p%iprcparm(mld_prec_status_) = mld_prec_built_ + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Done' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cbaseprc_bld + diff --git a/mlprec/mld_cdiag_bld.f90 b/mlprec/mld_cdiag_bld.f90 new file mode 100644 index 00000000..4abade86 --- /dev/null +++ b/mlprec/mld_cdiag_bld.f90 @@ -0,0 +1,159 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cdiag_bld.f90 +! +! Subroutine: mld_cdiag_bld +! Version: complex +! +! This routine builds the diagonal preconditioner corresponding to a given +! sparse matrix A. +! +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of the +! matrix A to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor associated to the sparse matrix A. +! p - type(mld_cbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the local +! part of the diagonal preconditioner. +! info - integer, output. +! Error code. +! +subroutine mld_cdiag_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cdiag_bld + + Implicit None + +! Arguments + type(psb_cspmat_type), target :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_cbaseprc_type),intent(inout) :: p + integer, intent(out) :: info + +! Local variables + Integer :: err_act,ictxt, me, np, n_row, n_col,i + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + name = 'mld_cdiag_bld' + info = 0 + ictxt = psb_cd_get_context(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),' Enter' + + call psb_realloc(n_col,p%d,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_realloc') + goto 9999 + end if + + ! + ! Retrieve the diagonal entries of the matrix A + ! + call psb_sp_getdiag(a,p%d,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getdiag' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! + ! Copy into p%desc_data the descriptor associated to A + ! + call psb_cdcpy(desc_a,p%desc_Data,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdcpy') + goto 9999 + end if + + ! + ! The i-th diagonal entry of the preconditioner is set to one if the + ! corresponding entry a_ii of the sparse matrix A is zero; otherwise + ! it is set to one/a_ii + ! + do i=1,n_row + if (p%d(i) == czero) then + p%d(i) = cone + else + p%d(i) = cone/p%d(i) + endif + end do + + if (a%pl(1) /= 0) then + ! + ! Apply the same row permutation as in the sparse matrix A + ! + call psb_gelp('n',a%pl,p%d,info) + if(info /= 0) then + info=4010 + ch_err='psb_gelp' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),'Done' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cdiag_bld + diff --git a/mlprec/mld_cfact_bld.f90 b/mlprec/mld_cfact_bld.f90 new file mode 100644 index 00000000..315fb6f5 --- /dev/null +++ b/mlprec/mld_cfact_bld.f90 @@ -0,0 +1,485 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cfact_bld.f90 +! +! Subroutine: mld_cfact_bld +! Version: complex +! +! This routine computes an LU or incomplete LU (ILU) factorization of the diagonal +! blocks of a distributed matrix, according to the value of +! p%iprcparm(iprcparm(sub_solve_), set by the user through +! mld_dprecinit or mld_dprecset. +! It may also compute an LU factorization of a distributed matrix, or split +! a distributed matrix into its block-diagonal and off block-diagonal parts, +! for the future application of multiple block-Jacobi sweeps. +! +! This routine is used by mld_as_bld, to build a 'base' block-Jacobi or +! Additive Schwarz (AS) preconditioner at any level of a multilevel preconditioner, +! or a block-Jacobi or LU or ILU solver at the coarsest level of a multilevel +! preconditioner. For the AS preconditioners, the diagonal blocks to be factorized +! are stored into the sparse matrix data structures a and blck, and blck contains +! the remote rows needed to build the extended local matrix as required by the +! AS preconditioner. +! +! More precisely, the routine performs one of the following tasks: +! +! 1. LU or ILU factorization of the diagonal blocks of the distributed matrix +! for the construction of a block-Jacobi or AS preconditioners +! (allowed at any level of a multilevel preconditioner); +! +! 2. setup of block-Jacobi sweeps to compute an approximate solution of a +! linear system +! A*Y = X, +! distributed among the processes (allowed only at the coarsest level); +! +! 3. LU factorization of the matrix of a linear system +! A*Y = X, +! distributed among the processes (allowed only at the coarsest level); +! +! 4. LU or incomplete LU factorization of the matrix of a linear system +! A*Y = X, +! replicated on the processes (allowed only at the coarsest level). +! +! The following factorizations are available: +! - ILU(k), i.e. ILU factorization with fill-in level k; +! - MILU(k), i.e. modified ILU factorization with fill-in level k; +! - ILU(k,t), i.e. ILU with threshold (i.e. drop tolerance) t and k additional +! entries in each row of the L and U factors with respect to the initial +! sparsity pattern; +! - serial LU implemented in SuperLU version 3.0; +! - serial LU implemented in UMFPACK version 4.4; +! - distributed LU implemented in SuperLU_DIST version 2.0. +! +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of the +! distributed matrix. +! p - type(mld_cbaseprec_type), input/output. +! The 'base preconditioner' data structure containing the local +! part of the preconditioner or solver at the current level. +! +! info - integer, output. +! Error code. +! upd - character, input. +! If upd='F' then the preconditioner is built from scratch; +! if upd=T' then the matrix to be preconditioned has the same +! sparsity pattern of a matrix that has been previously +! preconditioned, hence some information is reused in building +! the new preconditioner. +! blck - type(psb_cspmat_type), input, optional. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 blck is empty. +! +subroutine mld_cfact_bld(a,p,upd,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cfact_bld + + implicit none + +! Arguments + type(psb_cspmat_type), intent(in), target :: a + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + character, intent(in) :: upd + type(psb_cspmat_type), intent(in), target, optional :: blck + + ! Local Variables + type(psb_cspmat_type), pointer :: blck_ + type(psb_cspmat_type) :: atmp + integer :: ictxt,np,me,err_act + integer :: debug_level, debug_unit + integer :: k, m, int_err(5), n_row, nrow_a, n_col + character :: trans, unitd + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info=0 + name='mld_cfact_bld' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(p%desc_data) + call psb_info(ictxt, me, np) + + m = a%m + if (m < 0) then + info = 10 + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + trans = 'N' + unitd = 'U' + + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info ==0) call psb_sp_all(0,0,blck_,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + blck_%fida = 'COO' + blck_%infoa(psb_nnz_) = 0 + end if + call psb_nullify_sp(atmp) + + ! + ! Treat separately the case the local matrix has to be reordered + ! and the case this is not required. + ! + select case(p%iprcparm(mld_sub_ren_)) + + ! + ! A reordering of the local matrix is required. + ! + case (1:) + + ! + ! Reorder the rows and the columns of the local extended matrix, + ! according to the value of p%iprcparm(sub_ren_). The reordered + ! matrix is stored into atmp, using the COO format. + ! + call mld_sp_renum(a,blck_,p,atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='mld_sp_renum') + goto 9999 + end if + + ! + ! Clip into p%av(ap_nd_) the off block-diagonal part of the local + ! matrix. The clipped matrix is then stored in CSR format. + ! + if (p%iprcparm(mld_smooth_sweeps_) > 1) then + call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,& + & jmin=atmp%m+1,rscale=.false.,cscale=.false.) + if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,& + & afmt='csr',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_spcnv') + goto 9999 + end if + + k = psb_sp_get_nnzeros(p%av(mld_ap_nd_)) + call psb_sum(ictxt,k) + + if (k == 0) then + ! + ! If the off diagonal part is emtpy, there is no point in doing + ! multiple Jacobi sweeps. This is certain to happen when running + ! on a single processor. + ! + p%iprcparm(mld_smooth_sweeps_) = 1 + end if + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' Factoring rows ',& + & atmp%m,a%m,blck_%m,atmp%ia2(atmp%m+1)-1 + + ! + ! Compute a factorization of the diagonal block of the local matrix, + ! according to the choice made by the user by setting p%iprcparm(sub_solve_) + ! + select case(p%iprcparm(mld_sub_solve_)) + + case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + ! + ! ILU(k)/MILU(k)/ILU(k,t) factorization. + ! + call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) + if (info == 0) call mld_ilu_bld(atmp,p,upd,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='mld_ilu_bld') + goto 9999 + end if + + case(mld_slu_) + ! + ! LU factorization through the SuperLU package. + ! + call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) + if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_slu_bld') + goto 9999 + end if + + case(mld_sludist_) + ! + ! LU factorization through the SuperLU_DIST package. This works only + ! when the matrix is distributed among the processes. + ! NOTE: Should have NO overlap here!!!! + ! + call psb_spcnv(a,atmp,info,afmt='csr') + if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_sludist_bld') + goto 9999 + end if + + case(mld_umf_) + ! + ! LU factorization through the UMFPACK package. + ! + call psb_spcnv(atmp,info,afmt='csc',dupl=psb_dupl_add_) + if (info == 0) call mld_umf_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_umf_bld') + goto 9999 + end if + + case(mld_f_none_) + ! + ! Error: no factorization required. + ! + info=4001 + call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_') + goto 9999 + + case default + info=4001 + call psb_errpush(info,name,a_err='Unknown mld_sub_solve_') + goto 9999 + end select + + call psb_sp_free(atmp,info) + + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + ! + ! No reordering of the local matrix is required + ! + case(0) + ! + ! In case of multiple block-Jacobi sweeps, clip into p%av(ap_nd_) + ! the off block-diagonal part of the local extended matrix. The + ! clipped matrix is then stored in CSR format. + ! + + if (p%iprcparm(mld_smooth_sweeps_) > 1) then + n_row = psb_cd_get_local_rows(p%desc_data) + n_col = psb_cd_get_local_cols(p%desc_data) + nrow_a = a%m + ! The following is known to work + ! given that the output from CLIP is in COO. + call psb_sp_clip(a,p%av(mld_ap_nd_),info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == 0) call psb_sp_clip(blck_,atmp,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == 0) call psb_rwextd(n_row,p%av(mld_ap_nd_),info,b=atmp) + if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,& + & afmt='csr',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + + k = psb_sp_get_nnzeros(p%av(mld_ap_nd_)) + call psb_sum(ictxt,k) + + if (k == 0) then + ! + ! If the off block-diagonal part is emtpy, there is no point in doing + ! multiple Jacobi sweeps. This is certain to happen when running + ! on a single processor. + ! + p%iprcparm(mld_smooth_sweeps_) = 1 + end if + call psb_sp_free(atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + end if + ! + ! Compute a factorization of the diagonal block of the local matrix, + ! according to the choice made by the user by setting p%iprcparm(sub_solve_) + ! + select case(p%iprcparm(mld_sub_solve_)) + + case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + ! + ! ILU(k)/MILU(k)/ILU(k,t) factorization. + ! + ! + ! Compute the incomplete LU factorization. + ! + call mld_ilu_bld(a,p,upd,info,blck=blck_) + if (info/=0) then + call psb_errpush(4010,name,a_err='mld_ilu_bld') + goto 9999 + end if + + case(mld_slu_) + ! + ! LU factorization through the SuperLU package. + ! + n_row = psb_cd_get_local_rows(p%desc_data) + n_col = psb_cd_get_local_cols(p%desc_data) + call psb_spcnv(a,atmp,info,afmt='coo') + if (info == 0) call psb_rwextd(n_row,atmp,info,b=blck_) + + ! + ! Compute the LU factorization. + ! + if (info == 0) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) + if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_slu_bld') + goto 9999 + end if + + call psb_sp_free(atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + case(mld_sludist_) + ! + ! LU factorization through the SuperLU_DIST package. This works only + ! when the matrix is distributed among the processes. + ! NOTE: Should have NO overlap here!!!! + ! + call psb_spcnv(a,atmp,info,afmt='csr') + if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_sludist_bld') + goto 9999 + end if + + call psb_sp_free(atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + case(mld_umf_) + ! + ! LU factorization through the UMFPACK package. + ! + + call psb_spcnv(a,atmp,info,afmt='coo') + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_spcnv') + goto 9999 + end if + + n_row = psb_cd_get_local_rows(p%desc_data) + n_col = psb_cd_get_local_cols(p%desc_data) + call psb_rwextd(n_row,atmp,info,b=blck_) + + ! + ! Compute the LU factorization. + ! + if (info == 0) call psb_spcnv(atmp,info,afmt='csc',dupl=psb_dupl_add_) + if (info == 0) call mld_umf_bld(atmp,p%desc_data,p,info) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': Done mld_umf_bld ',info + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_umf_bld') + goto 9999 + end if + + call psb_sp_free(atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + case(mld_f_none_) + ! + ! Error: no factorization required. + ! + info=4001 + call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_') + goto 9999 + + case default + info=4001 + call psb_errpush(info,name,a_err='Unknown mld_sub_solve_') + goto 9999 + end select + + case default + info=4001 + call psb_errpush(info,name,a_err='Invalid renum_') + goto 9999 + end select + + if (.not.present(blck)) then + call psb_sp_free(blck_,info) + if (info == 0) deallocate(blck_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),'End ' + + call psb_erractionrestore(err_act) + + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine mld_cfact_bld + + diff --git a/mlprec/mld_cilu0_fact.f90 b/mlprec/mld_cilu0_fact.f90 new file mode 100644 index 00000000..c219edb4 --- /dev/null +++ b/mlprec/mld_cilu0_fact.f90 @@ -0,0 +1,648 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cilu0_fact.f90 +! +! Subroutine: mld_cilu0_fact +! Version: complex +! Contains: mld_cilu0_factint, ilu_copyin +! +! This routine computes either the ILU(0) or the MILU(0) factorization of the +! diagonal blocks of a distributed matrix. These factorizations +! are used to build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a given level of a multilevel +! preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is CSR. +! The diagonal of the U factor is stored separately (actually, the inverse of the +! diagonal entries is stored; this is then managed in the solve stage associated +! to the ILU(0)/MILU(0) factorization). +! +! The routine copies and factors "on the fly" from a and blck into l (L factor), +! u (U factor, except its diagonal) and d (diagonal of U). +! +! This implementation of ILU(0)/MILU(0) is faster than the implementation in +! mld_diluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). +! +! +! Arguments: +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The MILU(0) factorization is computed if ialg = 2 (= mld_milu_n_); +! the ILU(0) factorization otherwise. +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see mld_as_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_cspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_cspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! d - complex(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_cspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see mld_fact_bld), then blck is empty. +! +subroutine mld_cilu0_fact(ialg,a,l,u,d,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cilu0_fact + + implicit none + + ! Arguments + integer, intent(in) :: ialg + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + complex(psb_spk_), intent(inout) :: d(:) + integer, intent(out) :: info + type(psb_cspmat_type),intent(in), optional, target :: blck + + ! Local variables + integer :: l1, l2,m,err_act + type(psb_cspmat_type), pointer :: blck_ + character(len=20) :: name, ch_err + + name='mld_cilu0_fact' + info = 0 + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_nullify_sp(blck_) ! Probably pointless. + call psb_sp_all(0,0,blck_,1,info) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + blck_%m=0 + endif + + ! + ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg + ! + call mld_cilu0_factint(ialg,m,a%m,a,blck_%m,blck_,& + & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + if(info.ne.0) then + info=4010 + ch_err='mld_cilu0_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + l%infoa(1) = l1 + l%fida = 'CSR' + l%descra = 'TLU' + u%infoa(1) = l2 + u%fida = 'CSR' + u%descra = 'TUU' + l%m = m + l%k = m + u%m = m + u%k = m + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call psb_sp_free(blck_,info) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + ! + ! Subroutine: mld_cilu0_factint + ! Version: complex + ! Note: internal subroutine of mld_cilu0_fact. + ! + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' + ! (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a given level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(0)/MILU(0) factorization). + ! + ! The routine copies and factors "on the fly" from the sparse matrix structures a + ! and b into the arrays laspk, uaspk, d (L, U without its diagonal, diagonal of U). + ! + ! + ! Arguments: + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The ILU(0) factorization is computed if ialg = 1 (= mld_ilu_n_), + ! the MILU(0) one if ialg = 2 (= mld_milu_n_); other values + ! are not allowed. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! ma - integer, input + ! The number of rows of the local submatrix stored into a. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see mld_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! mb - integer, input. + ! The number of rows of the local submatrix stored into b. + ! b - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by mld_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been + ! reordered (see mld_fact_bld), then b does not contain any row. + ! d - complex(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the + ! incomplete factorization. + ! laspk - complex(psb_spk_), dimension(:), input/output. + ! The entries of U are stored according to the CSR format. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uaspk - complex(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uaspk, according to the CSR storage format. + ! l1 - integer, output. + ! The number of nonzero entries in laspk. + ! l2 - integer, output. + ! The number of nonzero entries in uaspk. + ! info - integer, output. + ! Error code. + ! + subroutine mld_cilu0_factint(ialg,m,ma,a,mb,b,& + & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + + implicit none + + ! Arguments + integer, intent(in) :: ialg + type(psb_cspmat_type),intent(in) :: a,b + integer,intent(inout) :: m,l1,l2,info + integer, intent(in) :: ma,mb + integer, dimension(:), intent(inout) :: lia1,lia2,uia1,uia2 + complex(psb_spk_), dimension(:), intent(inout) :: laspk,uaspk,d + + ! Local variables + integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act + complex(psb_spk_) :: dia,temp + integer, parameter :: nrb=16 + type(psb_cspmat_type) :: trw + integer :: int_err(5) + character(len=20) :: name, ch_err + + name='mld_cilu0_factint' + if(psb_get_errstatus().ne.0) return + info=0 + call psb_erractionsave(err_act) + + select case(ialg) + case(mld_ilu_n_,mld_milu_n_) + ! Ok + case default + info=35 + call psb_errpush(info,name,i_err=(/1,ialg,0,0,0/)) + goto 9999 + end select + + call psb_nullify_sp(trw) + trw%m=0 + trw%k=0 + + call psb_sp_all(trw,1,info) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + lia2(1) = 1 + uia2(1) = 1 + l1 = 0 + l2 = 0 + m = ma+mb + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + d(i) = czero + + if (i <= ma) then + ! + ! Copy the i-th local row of the matrix, stored in a, + ! into laspk/d(i)/uaspk + ! + call ilu_copyin(i,ma,a,i,1,m,l1,lia1,laspk,& + & d(i),l2,uia1,uaspk,ktrw,trw) + else + ! + ! Copy the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row), into laspk/d(i)/uaspk + ! + call ilu_copyin(i-ma,mb,b,i,1,m,l1,lia1,laspk,& + & d(i),l2,uia1,uaspk,ktrw,trw) + endif + + lia2(i+1) = l1 + 1 + uia2(i+1) = l2 + 1 + + dia = d(i) + do kk = lia2(i), lia2(i+1) - 1 + ! + ! Compute entry l(i,k) (lower factor L) of the incomplete + ! factorization + ! + temp = laspk(kk) + k = lia1(kk) + laspk(kk) = temp*d(k) + ! + ! Update the rest of row i (lower and upper factors L and U) + ! using l(i,k) + ! + low1 = kk + 1 + low2 = uia2(i) + ! + updateloop: do jj = uia2(k), uia2(k+1) - 1 + ! + j = uia1(jj) + ! + if (j < i) then + ! + ! search l(i,*) (i-th row of L) for a matching index j + ! + do ll = low1, lia2(i+1) - 1 + l = lia1(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + laspk(ll) = laspk(ll) - temp*uaspk(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + + else if (j == i) then + ! + ! j=i: update the diagonal + ! + dia = dia - temp*uaspk(jj) + cycle updateloop + ! + else if (j > i) then + ! + ! search u(i,*) (i-th row of U) for a matching index j + ! + do ll = low2, uia2(i+1) - 1 + l = uia1(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uaspk(ll) = uaspk(ll) - temp*uaspk(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if + ! + ! If we get here we missed the cycle updateloop, which means + ! that this entry does not match; thus we accumulate on the + ! diagonal for MILU(0). + ! + if (ialg == mld_milu_n_) then + dia = dia - temp*uaspk(jj) + end if + enddo updateloop + enddo + ! + ! Check the pivot size + ! + if (abs(dia) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = 2 + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + dia = done/dia + end if + d(i) = dia + ! + ! Scale row i of upper triangle + ! + do kk = uia2(i), uia2(i+1) - 1 + uaspk(kk) = uaspk(kk)*dia + enddo + enddo + + call psb_sp_free(trw,info) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mld_cilu0_factint + + ! + ! Subroutine: ilu_copyin + ! Version: complex + ! Note: internal subroutine of mld_cilu0_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type + ! data structure a, into the arrays laspk and uaspk and into the scalar variable + ! dia, corresponding to the lower and upper triangles of A and to the diagonal + ! entry of the row, respectively. The entries in laspk and uaspk are stored + ! according to the CSR format; the corresponding column indices are stored in + ! the arrays lia1 and uia1. + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied into laspk, dia, uaspk row by row, through successive calls to + ! ilu_copyin. + ! + ! The routine is used by mld_cilu0_factint in the computation of the ILU(0)/MILU(0) + ! factorization of a local sparse matrix. + ! + ! TODO: modify the routine to allow copying into output L and U that are + ! already filled with indices; this would allow computing an ILU(k) pattern, + ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! Minimum valid column index. + ! jmax - integer, input. + ! Maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! l1 - integer, input/output. + ! Pointer to the last occupied entry of laspk. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the lower triangle + ! copied in laspk row by row (see mld_cilu0_factint), according + ! to the CSR storage format. + ! laspk - complex(psb_spk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! lower triangle are copied. + ! dia - complex(psb_spk_), output. + ! The diagonal entry of the copied row. + ! l2 - integer, input/output. + ! Pointer to the last occupied entry of uaspk. + ! uia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the upper triangle + ! copied in uaspk row by row (see mld_cilu0_factint), according + ! to the CSR storage format. + ! uaspk - complex(psb_spk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! upper triangle are copied. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_cspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lia1,laspk,& + & dia,l2,uia1,uaspk,ktrw,trw) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(inout) :: trw + integer, intent(in) :: i,m,jd,jmin,jmax + integer, intent(inout) :: ktrw,l1,l2 + integer, intent(inout) :: lia1(:), uia1(:) + complex(psb_spk_), intent(inout) :: laspk(:), uaspk(:), dia + + ! Local variables + integer :: k,j,info,irb + integer, parameter :: nrb=16 + character(len=20), parameter :: name='ilu_copyin' + character(len=20) :: ch_err + + if (psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (psb_toupper(a%fida)=='CSR') then + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = a%ia2(i), a%ia2(i+1) - 1 + k = a%ia1(j) + ! write(0,*)'KKKKK',k + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + laspk(l1) = a%aspk(j) + lia1(l1) = k + else if (k == jd) then + dia = a%aspk(j) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uaspk(l2) = a%aspk(j) + uia1(l2) = k + end if + enddo + + else + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into laspk, dia, uaspk, through + ! successive calls to ilu_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb==1)) then + irb = min(m-i+1,nrb) + call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + laspk(l1) = trw%aspk(ktrw) + lia1(l1) = k + else if (k == jd) then + dia = trw%aspk(ktrw) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uaspk(l2) = trw%aspk(ktrw) + uia1(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine ilu_copyin + +end subroutine mld_cilu0_fact diff --git a/mlprec/mld_cilu_bld.f90 b/mlprec/mld_cilu_bld.f90 new file mode 100644 index 00000000..db6385f5 --- /dev/null +++ b/mlprec/mld_cilu_bld.f90 @@ -0,0 +1,280 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cilu_bld.f90 +! +! Subroutine: mld_cilu_bld +! Version: complex +! +! This routine computes an incomplete LU (ILU) factorization of the diagonal +! blocks of a distributed matrix. This factorization is used to build the +! 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz +! preconditioner) corresponding to a certain level of a multilevel preconditioner. +! +! The following factorizations are available: +! - ILU(k), i.e. ILU factorization with fill-in level k, +! - MILU(k), i.e. modified ILU factorization with fill-in level k, +! - ILU(k,t), i.e. ILU with threshold (i.e. drop tolerance) t and k additional +! entries in each row of the L and U factors with respect to the initial +! sparsity pattern. +! Note that the meaning of k in ILU(k,t) is different from that in ILU(k) and +! MILU(k). +! +! For details on the above factorizations see +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! Note that that this routine handles the ILU(0) factorization separately, +! through mld_ilu0_fact, for performance reasons. +! +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if p%iprcparm(mld_n_ovr_) > 0, i.e. the +! 'base' Additive Schwarz preconditioner has overlap greater than +! 0, and p%iprcparm(mld_sub_ren_) = 0, i.e. a reordering of the +! matrix has not been performed (see mld_fact_bld), then a contains +! only the 'original' local part of the distributed matrix, +! i.e. the rows of the matrix held by the calling process according +! to the initial data distribution. +! p - type(mld_cbaseprc_type), input/output. +! The 'base preconditioner' data structure. In input, p%iprcparm +! contains information on the type of factorization to be computed. +! In output, p%av(mld_l_pr_) and p%av(mld_u_pr_) contain the +! incomplete L and U factors (without their diagonals), and p%d +! contains the diagonal of the incomplete U factor. For more +! details on p see its description in mld_prec_type.f90. +! info - integer, output. +! Error code. +! blck - type(psb_cspmat_type), input, optional. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see mld_fact_bld), then blck does not contain any row. +! +subroutine mld_cilu_bld(a,p,upd,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cilu_bld + + implicit none + +! Arguments + type(psb_cspmat_type), intent(in), target :: a + type(mld_cbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + integer, intent(out) :: info + type(psb_cspmat_type), intent(in), optional :: blck + + ! Local Variables + integer :: i, nztota, err_act, n_row, nrow_a + character :: trans, unitd + integer :: debug_level, debug_unit + integer :: ictxt,np,me + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info=0 + name='mld_cilu_bld' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(p%desc_data) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + trans = 'N' + unitd = 'U' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + + if (allocated(p%av)) then + if (size(p%av) < mld_bp_ilu_avsz_) then + do i=1,size(p%av) + call psb_sp_free(p%av(i),info) + if (info /= 0) then + ! Actually, we don't care here about this. Just let it go. + ! return + end if + enddo + deallocate(p%av,stat=info) + endif + end if + if (.not.allocated(p%av)) then + allocate(p%av(mld_max_avsz_),stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + endif + + nrow_a = psb_sp_get_nrows(a) + nztota = psb_sp_get_nnzeros(a) + if (present(blck)) then + nztota = nztota + psb_sp_get_nnzeros(blck) + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nztota,a%m,a%k,nrow_a + + n_row = p%desc_data%matrix_data(psb_n_row_) + p%av(mld_l_pr_)%m = n_row + p%av(mld_l_pr_)%k = n_row + p%av(mld_u_pr_)%m = n_row + p%av(mld_u_pr_)%k = n_row + call psb_sp_all(n_row,n_row,p%av(mld_l_pr_),nztota,info) + if (info == 0) call psb_sp_all(n_row,n_row,p%av(mld_u_pr_),nztota,info) + if(info/=0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(p%d)) then + if (size(p%d) < n_row) then + deallocate(p%d) + endif + endif + if (.not.allocated(p%d)) then + allocate(p%d(n_row),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + + select case(p%iprcparm(mld_sub_solve_)) + + case (mld_ilu_t_) + ! + ! ILU(k,t) + ! + + select case(p%iprcparm(mld_sub_fill_in_)) + + case(:-1) + ! Error: fill-in <= -1 + call psb_errpush(30,name,i_err=(/3,p%iprcparm(mld_sub_fill_in_),0,0,0/)) + goto 9999 + + case(0:) + ! Fill-in >= 0 + call mld_ilut_fact(p%iprcparm(mld_sub_fill_in_),p%rprcparm(mld_fact_thrs_),& + & a, p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) + end select + if(info/=0) then + info=4010 + ch_err='mld_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(mld_ilu_n_,mld_milu_n_) + ! + ! ILU(k) and MILU(k) + ! + select case(p%iprcparm(mld_sub_fill_in_)) + case(:-1) + ! Error: fill-in <= -1 + call psb_errpush(30,name,i_err=(/3,p%iprcparm(mld_sub_fill_in_),0,0,0/)) + goto 9999 + case(0) + ! Fill-in 0 + ! Separate implementation of ILU(0) for better performance. + ! There seems to be a problem with the separate implementation of MILU(0), + ! contained into mld_ilu0_fact. This must be investigated. For the time being, + ! resort to the implementation of MILU(k) with k=0. + if (p%iprcparm(mld_sub_solve_) == mld_ilu_n_) then + call mld_ilu0_fact(p%iprcparm(mld_sub_solve_),a,p%av(mld_l_pr_),p%av(mld_u_pr_),& + & p%d,info,blck=blck) + else + call mld_iluk_fact(p%iprcparm(mld_sub_fill_in_),p%iprcparm(mld_sub_solve_),& + & a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) + endif + case(1:) + ! Fill-in >= 1 + ! The same routine implements both ILU(k) and MILU(k) + call mld_iluk_fact(p%iprcparm(mld_sub_fill_in_),p%iprcparm(mld_sub_solve_),& + & a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) + end select + if (info/=0) then + info=4010 + ch_err='mld_iluk_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case default + ! If we end up here, something was wrong up in the call chain. + call psb_errpush(4000,name) + goto 9999 + + end select + + if (psb_sp_getifld(psb_upd_,p%av(mld_u_pr_),info) /= psb_upd_perm_) then + call psb_sp_trim(p%av(mld_u_pr_),info) + endif + + if (psb_sp_getifld(psb_upd_,p%av(mld_l_pr_),info) /= psb_upd_perm_) then + call psb_sp_trim(p%av(mld_l_pr_),info) + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cilu_bld + + diff --git a/mlprec/mld_ciluk_fact.f90 b/mlprec/mld_ciluk_fact.f90 new file mode 100644 index 00000000..edf12d6e --- /dev/null +++ b/mlprec/mld_ciluk_fact.f90 @@ -0,0 +1,971 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_ciluk_fact.f90 +! +! Subroutine: mld_ciluk_fact +! Version: complex +! Contains: mld_ciluk_factint, iluk_copyin, iluk_fact, iluk_copyout +! +! This routine computes either the ILU(k) or the MILU(k) factorization of the +! diagonal blocks of a distributed matrix. These factorizations are used to build +! the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a certain level of a multilevel +! preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in +! the description of the arguments below. The storage format for both the L and +! U factors is CSR. The diagonal of the U factor is stored separately (actually, +! the inverse of the diagonal entries is stored; this is then managed in the solve +! stage associated to the ILU(k)/MILU(k) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in level k in ILU(k)/MILU(k). +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The ILU(k) factorization is computed if ialg = 1 (= mld_ilu_n_); +! the MILU(k) one if ialg = 2 (= mld_milu_n_); other values are +! not allowed. +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see mld_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_cspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_cspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! d - complex(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_cspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see mld_fact_bld), then blck does not contain any row. +! +subroutine mld_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_ciluk_fact + + implicit none + + ! Arguments + integer, intent(in) :: fill_in, ialg + integer, intent(out) :: info + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + type(psb_cspmat_type),intent(in), optional, target :: blck + complex(psb_spk_), intent(inout) :: d(:) + ! Local Variables + integer :: l1, l2, m, err_act + + type(psb_cspmat_type), pointer :: blck_ + character(len=20) :: name, ch_err + + name='mld_ciluk_fact' + info = 0 + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_sp_all(0,0,blck_,1,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + + ! + ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg + ! + call mld_ciluk_factint(fill_in,ialg,m,a,blck_,& + & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + if (info /= 0) then + info=4010 + ch_err='mld_ciluk_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + l%infoa(1) = l1 + l%fida = 'CSR' + l%descra = 'TLU' + u%infoa(1) = l2 + u%fida = 'CSR' + u%descra = 'TUU' + l%m = m + l%k = m + u%m = m + u%k = m + + ! + ! Nullify the pointer / deallocate the memory + ! + if (present(blck)) then + blck_ => null() + else + call psb_sp_free(blck_,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + ! + ! Subroutine: mld_ciluk_factint + ! Version: complex + ! Note: internal subroutine of mld_ciluk_fact + ! + ! This routine computes either the ILU(k) or the MILU(k) factorization of the + ! diagonal blocks of a distributed matrix. These factorizations are used to build + ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k)/MILU(k) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in level k in ILU(k)/MILU(k). + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The MILU(k) factorization is computed if ialg = 2 (= mld_milu_n_); + ! the ILU(k) factorization otherwise. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see mld_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by mld_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see mld_fact_bld), then b does not contain any row. + ! d - complex(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! laspk - complex(psb_spk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uaspk - complex(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uaspk, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in laspk. + ! l2 - integer, output + ! The number of nonzero entries in uaspk. + ! info - integer, output. + ! Error code. + ! + subroutine mld_ciluk_factint(fill_in,ialg,m,a,b,& + & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + + use psb_base_mod + + implicit none + + ! Arguments + integer, intent(in) :: fill_in, ialg + type(psb_cspmat_type), intent(in) :: a,b + integer, intent(inout) :: m,l1,l2,info + integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) + complex(psb_spk_), allocatable, intent(inout) :: laspk(:),uaspk(:) + complex(psb_spk_), intent(inout) :: d(:) + + ! Local variables + integer :: ma,mb,i, ktrw,err_act,nidx + integer, allocatable :: uplevs(:), rowlevs(:),idxs(:) + complex(psb_spk_), allocatable :: row(:) + type(psb_int_heap) :: heap + logical,parameter :: debug=.false. + type(psb_cspmat_type) :: trw + character(len=20), parameter :: name='mld_ciluk_factint' + character(len=20) :: ch_err + + if (psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + select case(ialg) + case(mld_ilu_n_,mld_milu_n_) + ! Ok + case default + info=35 + call psb_errpush(info,name,i_err=(/2,ialg,0,0,0/)) + goto 9999 + end select + if (fill_in < 0) then + info=35 + call psb_errpush(info,name,i_err=(/1,fill_in,0,0,0/)) + goto 9999 + end if + + ma = a%m + mb = b%m + m = ma+mb + + ! + ! Allocate a temporary buffer for the iluk_copyin function + ! + call psb_sp_all(0,0,trw,1,info) + if (info==0) call psb_ensure_size(m+1,lia2,info) + if (info==0) call psb_ensure_size(m+1,uia2,info) + + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lia2(1) = 1 + uia2(1) = 1 + + ! + ! Allocate memory to hold the entries of a row and the corresponding + ! fill levels + ! + allocate(uplevs(size(uaspk)),rowlevs(m),row(m),stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + uplevs(:) = m+1 + row(:) = czero + rowlevs(:) = -(m+1) + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the iluk_copyin routine, and updated during the elimination, in + ! the iluk_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = czero + if (i<=ma) then + ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! + call iluk_copyin(i,ma,a,1,m,row,rowlevs,heap,ktrw,trw,info) + else + ! + ! Copy into trw the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row) + ! + call iluk_copyin(i-ma,mb,b,1,m,row,rowlevs,heap,ktrw,trw,info) + endif + + ! Do an elimination step on the current row. It turns out we only + ! need to keep track of fill levels for the upper triangle, hence we + ! do not have a lowlevs variable. + ! + if (info == 0) call iluk_fact(fill_in,i,row,rowlevs,heap,& + & d,uia1,uia2,uaspk,uplevs,nidx,idxs,info) + ! + ! Copy the row into laspk/d(i)/uaspk + ! + if (info == 0) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& + & l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,uplevs,info) + if (info /= 0) then + info=4001 + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + end do + + ! + ! And we're done, so deallocate the memory + ! + deallocate(uplevs,rowlevs,row,stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == 0) call psb_sp_free(trw,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mld_ciluk_factint + + ! + ! Subroutine: iluk_copyin + ! Version: complex + ! Note: internal subroutine of mld_ciluk_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the sparse matrix + ! structure a, into the array row and stores into a heap the column indices of + ! the nonzero entries of the copied row. The output array row is such that it + ! contains a full row of A, i.e. it contains also the zero entries of the row. + ! This is useful for the elimination step performed by iluk_fact after the call + ! to iluk_copyin (see mld_iluk_factint). + ! The routine also sets to zero the entries of the array rowlevs corresponding + ! to the nonzero entries of the copied row (see the description of the arguments + ! below). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilu_copyin. + ! + ! This routine is used by mld_ciluk_factint in the computation of the + ! ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! row - complex(psb_spk_), dimension(:), input/output. + ! In input it is the null vector (see mld_iluk_factint and + ! iluk_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /=0, for + ! future use in iluk_fact. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_sspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(inout) :: trw + integer, intent(in) :: i,m,jmin,jmax + integer, intent(inout) :: ktrw,info + integer, intent(inout) :: rowlevs(:) + complex(psb_spk_), intent(inout) :: row(:) + type(psb_int_heap), intent(inout) :: heap + + ! Local variables + integer :: k,j,irb,err_act + integer, parameter :: nrb=16 + character(len=20), parameter :: name='iluk_copyin' + character(len=20) :: ch_err + + if (psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + call psb_init_heap(heap,info) + + if (psb_toupper(a%fida)=='CSR') then + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = a%ia2(i), a%ia2(i+1) - 1 + k = a%ia1(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = a%aspk(j) + rowlevs(k) = 0 + call psb_insert_heap(k,heap,info) + end if + end do + + else + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to iluk_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb==1)) then + irb = min(m-i+1,nrb) + call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + if (info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%aspk(ktrw) + rowlevs(k) = 0 + call psb_insert_heap(k,heap,info) + end if + ktrw = ktrw + 1 + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine iluk_copyin + + ! + ! Subroutine: iluk_fact + ! Version: complex + ! Note: internal subroutine of mld_ciluk_fact + ! + ! This routine does an elimination step of the ILU(k) factorization on a + ! single matrix row (see the calling routine mld_iluk_factint). + ! + ! This step is also the base for a MILU(k) elimination step on the row (see + ! iluk_copyout). This routine is used by mld_ciluk_factint in the computation + ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! NOTE: it turns out we only need to keep track of the fill levels for + ! the upper triangle. + ! + ! + ! Arguments + ! fill_in - integer, input. + ! The fill-in level k in ILU(k). + ! i - integer, input. + ! The local index of the row to which the factorization is + ! applied. + ! row - complex(psb_spk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = 0 if the k-th entry of the row is + ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output + ! rowlevs(k) contains the fill kevel of the k-th entry of + ! the row after the current elimination step; rowlevs(k) = -(m+1) + ! means that the k-th row entry is zero throughout the elimination + ! step. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the indices concerning the transformed row. + ! d - complex(psb_spk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see iluk_copyout). + ! uia1 - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uaspk row by row (see + ! iluk_copyout, called by mld_ciluk_factint), according to the CSR + ! storage format. + ! uia2 - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uaspk row by row + ! (see iluk_copyout, called by mld_ciluk_factint), according to + ! the CSR storage format. + ! uaspk - complex(psb_spk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! uplevs - integer, dimension(:), input. + ! The fill levels of the nonzero entries in the part of the + ! U factor above the current row. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine iluk_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine iluk_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by this routine. + ! + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uia1,uia2,uaspk,uplevs,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_int_heap), intent(inout) :: heap + integer, intent(in) :: i, fill_in + integer, intent(inout) :: nidx,info + integer, intent(inout) :: rowlevs(:) + integer, allocatable, intent(inout) :: idxs(:) + integer, intent(inout) :: uia1(:),uia2(:),uplevs(:) + complex(psb_spk_), intent(inout) :: row(:), uaspk(:),d(:) + + ! Local variables + integer :: k,j,lrwk,jj,lastk, iret + complex(psb_spk_) :: rwk + + info = 0 + if (.not.allocated(idxs)) then + allocate(idxs(200),stat=info) + if (info /= 0) return + endif + nidx = 0 + lastk = -1 + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call psb_heap_get_first(k,heap,iret) + if (iret < 0) return + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= 0) return + end if + idxs(nidx) = k + if ((row(k) /= czero).and.(rowlevs(k) <= fill_in).and.(ki) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uaspk) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max((l2/i)*m,int(1.2*l2),l2+100) + call psb_realloc(isz,uaspk,info) + if (info == 0) call psb_realloc(isz,uia1,info) + if (info == 0) call psb_realloc(isz,uplevs,info,pad=(m+1)) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uia1(l2) = j + uaspk(l2) = row(j) + uplevs(l2) = rowlevs(j) + else if (ialg == mld_milu_n_) then + ! + ! MILU(k): add discarded entries to the diagonal one + ! + d(i) = d(i) + row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = czero + rowlevs(j) = -(m+1) + end if + end do + + ! + ! Store the pointers to the first non occupied entry of in + ! laspk and uaspk + ! + lia2(i+1) = l1 + 1 + uia2(i+1) = l2 + 1 + + ! + ! Check the pivot size + ! + if (abs(d(i)) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = 2 + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = cone/d(i) + end if + + ! + ! Scale the upper part + ! + do j=uia2(i), uia2(i+1)-1 + uaspk(j) = d(i)*uaspk(j) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + + end subroutine iluk_copyout + + +end subroutine mld_ciluk_fact diff --git a/mlprec/mld_cilut_fact.f90 b/mlprec/mld_cilut_fact.f90 new file mode 100644 index 00000000..26c70b41 --- /dev/null +++ b/mlprec/mld_cilut_fact.f90 @@ -0,0 +1,1159 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cilut_fact.f90 +! +! Subroutine: mld_cilut_fact +! Version: real +! Contains: mld_cilut_factint, ilut_copyin, ilut_fact, ilut_copyout +! +! This routine computes the ILU(k,t) factorization of the diagonal blocks of a +! distributed matrix. This factorization is used to build the 'base +! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz +! preconditioner) corresponding to a certain level of a multilevel preconditioner. +! +! Details on the above factorization can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in +! the description of the arguments below. The storage format for both the L and +! U factors is CSR. The diagonal of the U factor is stored separately (actually, +! the inverse of the diagonal entries is stored; this is then managed in the solve +! stage associated to the ILU(k,t) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in parameter k in ILU(k,t). +! thres - integer, input. +! The threshold t, i.e. the drop tolerance, in ILU(k,t). +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see mld_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_cspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_cspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! d - complex(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_cspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see mld_fact_bld), then blck does not contain any row. +! +subroutine mld_cilut_fact(fill_in,thres,a,l,u,d,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cilut_fact + + implicit none + + ! Arguments + integer, intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + integer, intent(out) :: info + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + complex(psb_spk_), intent(inout) :: d(:) + type(psb_cspmat_type),intent(in), optional, target :: blck + + ! Local Variables + integer :: l1, l2, m, err_act + + type(psb_cspmat_type), pointer :: blck_ + character(len=20) :: name, ch_err + + name='mld_cilut_fact' + info = 0 + call psb_erractionsave(err_act) + + if (fill_in < 0) then + info=35 + call psb_errpush(info,name,i_err=(/1,fill_in,0,0,0/)) + goto 9999 + end if + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_sp_all(0,0,blck_,1,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + + ! + ! Compute the ILU(k,t) factorization + ! + call mld_cilut_factint(fill_in,thres,m,a,blck_,& + & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + if (info /= 0) then + info=4010 + ch_err='mld_cilut_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + l%infoa(1) = l1 + l%fida = 'CSR' + l%descra = 'TLU' + u%infoa(1) = l2 + u%fida = 'CSR' + u%descra = 'TUU' + l%m = m + l%k = m + u%m = m + u%k = m + + ! + ! Nullify the pointer / deallocate the memory + ! + if (present(blck)) then + blck_ => null() + else + call psb_sp_free(blck_,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + ! + ! Subroutine: mld_cilut_factint + ! Version: real + ! Note: internal subroutine of mld_cilut_fact + ! + ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a + ! distributed matrix. This factorization is used to build the 'base + ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix to be factorized is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k,t) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in parameter k in ILU(k,t). + ! thres - integer, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see mld_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by mld_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see mld_fact_bld), then b does not contain any row. + ! d - complex(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! laspk - complex(psb_spk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uaspk - complex(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uaspk, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in laspk. + ! l2 - integer, output + ! The number of nonzero entries in uaspk. + ! info - integer, output. + ! Error code. + ! + subroutine mld_cilut_factint(fill_in,thres,m,a,b,& + & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + + use psb_base_mod + + implicit none + + ! Arguments + integer, intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + type(psb_cspmat_type), intent(in) :: a,b + integer, intent(inout) :: m,l1,l2,info + integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) + complex(psb_spk_), allocatable, intent(inout) :: laspk(:),uaspk(:) + complex(psb_spk_), intent(inout) :: d(:) + + ! Local Variables + integer :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb + real(psb_spk_) :: nrmi + integer, allocatable :: idxs(:) + complex(psb_spk_), allocatable :: row(:) + type(psb_int_heap) :: heap + type(psb_cspmat_type) :: trw + character(len=20), parameter :: name='mld_cilut_factint' + character(len=20) :: ch_err + + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + + + ma = a%m + mb = b%m + m = ma+mb + + ! + ! Allocate a temporary buffer for the ilut_copyin function + ! + call psb_sp_all(0,0,trw,1,info) + if (info==0) call psb_ensure_size(m+1,lia2,info) + if (info==0) call psb_ensure_size(m+1,uia2,info) + + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lia2(1) = 1 + uia2(1) = 1 + + ! + ! Allocate memory to hold the entries of a row + ! + allocate(row(m),stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + row(:) = czero + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the ilut_copyin function, and updated during the elimination, in + ! the ilut_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = czero + if (i<=ma) then + call ilut_copyin(i,ma,a,i,1,m,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) + else + call ilut_copyin(i-ma,mb,b,i,1,m,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) + endif + + ! + ! Do an elimination step on current row + ! + if (info == 0) call ilut_fact(thres,i,nrmi,row,heap,& + & d,uia1,uia2,uaspk,nidx,idxs,info) + ! + ! Copy the row into laspk/d(i)/uaspk + ! + if (info == 0) call ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row,nidx,idxs,& + & l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,info) + + if (info /= 0) then + info=4001 + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + + end do + + ! + ! And we're done, so deallocate the memory + ! + deallocate(row,idxs,stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == 0) call psb_sp_free(trw,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mld_cilut_factint + + ! + ! Subroutine: ilut_copyin + ! Version: complex + ! Note: internal subroutine of mld_cilut_fact + ! + ! This routine performs the following tasks: + ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, + ! into the array row; + ! - storing into a heap the column indices of the nonzero entries of the copied + ! row; + ! - computing the column index of the first entry with maximum absolute value + ! in the part of the row belonging to the upper triangle; + ! - computing the 2-norm of the row. + ! The output array row is such that it contains a full row of A, i.e. it contains + ! also the zero entries of the row. This is useful for the elimination step + ! performed by ilut_fact after the call to ilut_copyin (see mld_ilut_factint). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilut_copyin. + ! + ! This routine is used by mld_cilut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the row to be + ! copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! nlw - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the lower triangle of the matrix. + ! nup - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the upper triangle of the matrix. + ! jmaxup - integer, output. + ! The column index of the first entry with maximum absolute + ! value in the part of the row belonging to the upper triangle + ! nrmi - real(psb_spk_), output. + ! The 2-norm of the current row. + ! row - complex(psb_spk_), dimension(:), input/output. + ! In input it is the null vector (see mld_ilut_factint and + ! ilut_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /=0, for + ! future use in ilut_fact. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_cspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) + use psb_base_mod + implicit none + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(inout) :: trw + integer, intent(in) :: i, m,jmin,jmax,jd + integer, intent(inout) :: ktrw,nlw,nup,jmaxup,info + real(psb_spk_), intent(inout) :: nrmi + complex(psb_spk_), intent(inout) :: row(:) + type(psb_int_heap), intent(inout) :: heap + + integer :: k,j,irb,kin,nz + integer, parameter :: nrb=16 + real(psb_spk_) :: dmaxup + real(psb_spk_), external :: scnrm2 + character(len=20), parameter :: name='mld_cilut_factint' + + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + + call psb_init_heap(heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = dzero + nrmi = dzero + + if (psb_toupper(a%fida)=='CSR') then + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = a%ia2(i), a%ia2(i+1) - 1 + k = a%ia1(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = a%aspk(j) + call psb_insert_heap(k,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end if + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end do + nz = a%ia2(i+1) - a%ia2(i) + nrmi = scnrm2(nz,a%aspk(a%ia2(i)),ione) + else + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to ilut_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb==1)) then + irb = min(m-i+1,nrb) + call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_sp_getblk') + goto 9999 + end if + ktrw=1 + end if + + kin = ktrw + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%aspk(ktrw) + call psb_insert_heap(k,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end if + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + ktrw = ktrw + 1 + enddo + nz = ktrw - kin + nrmi = scnrm2(nz,trw%aspk(kin),ione) + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine ilut_copyin + + ! + ! Subroutine: ilut_fact + ! Version: complex + ! Note: internal subroutine of mld_cilut_fact + ! + ! This routine does an elimination step of the ILU(k,t) factorization on a single + ! matrix row (see the calling routine mld_ilut_factint). Actually, only the dropping + ! rule based on the threshold is applied here. The dropping rule based on the + ! fill-in is applied by ilut_copyout. + ! + ! The routine is used by mld_cilut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments + ! thres - integer, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! i - integer, input. + ! The local index of the row to which the factorization is applied. + ! nrmi - real(psb_spk_), input. + ! The 2-norm of the row to which the elimination step has to be + ! applied. + ! row - complex(psb_spk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the previous indices plus the ones corresponding to transformed + ! entries in the 'upper part' that have not been dropped. + ! d - complex(psb_spk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see ilut_copyout). + ! uia1 - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uaspk row by row (see + ! ilut_copyout, called by mld_cilut_factint), according to the CSR + ! storage format. + ! uia2 - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uaspk row by row + ! (see ilut_copyout, called by mld_cilut_factint), according to + ! the CSR storage format. + ! uaspk - complex(psb_spk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine ilut_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine ilut_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by this routine. + ! + subroutine ilut_fact(thres,i,nrmi,row,heap,d,uia1,uia2,uaspk,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_int_heap), intent(inout) :: heap + integer, intent(in) :: i + integer, intent(inout) :: nidx,info + real(psb_spk_), intent(in) :: thres,nrmi + integer, allocatable, intent(inout) :: idxs(:) + integer, intent(inout) :: uia1(:),uia2(:) + complex(psb_spk_), intent(inout) :: row(:), uaspk(:),d(:) + + ! Local Variables + integer :: k,j,jj,lastk, iret + complex(psb_spk_) :: rwk + + info = 0 + call psb_ensure_size(200,idxs,info) + if (info /= 0) return + nidx = 0 + lastk = -1 + ! + ! Do while there are indices to be processed + ! + do + + call psb_heap_get_first(k,heap,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + lowert: if (k nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call psb_insert_heap(witem,widx,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + ! + ! Now we have to take out the first nlw+fill_in entries + ! + if (nz <= nlw+fill_in) then + ! + ! Just copy everything from xw, and it is already ordered + ! + else + nz = nlw+fill_in + do k=1,nz + call psb_heap_get_first(witem,widx,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_heap_get_first') + goto 9999 + end if + + xw(k) = witem + xwid(k) = widx + end do + end if + + ! + ! Now put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the lower part of the row + ! + do k=1,nz + l1 = l1 + 1 + if (size(laspk) < l1) then + ! + ! Figure out a good reallocation size! + ! + isz = (max((l1/i)*m,int(1.2*l1),l1+100)) + call psb_realloc(isz,laspk,info) + if (info == 0) call psb_realloc(isz,lia1,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + lia1(l1) = xwid(k) + laspk(l1) = xw(indx(k)) + end do + + ! + ! Make sure idxp points to the diagonal entry + ! + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + if (idxp > size(idxs)) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else + if (idxs(idxp) > i) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else if (idxs(idxp) /= i) then +!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' + else + ! + ! Copy the diagonal entry + ! + widx = idxs(idxp) + witem = row(widx) + d(i) = witem + if (abs(d(i)) < epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = 2 + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = done/d(i) + end if + end if + end if + + ! + ! Now the upper part + ! + + call psb_init_heap(heap,info,dir=psb_asort_down_) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + nz = 0 + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx <= i) then +!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then +!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call psb_insert_heap(witem,widx,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call psb_heap_get_first(witem,widx,heap,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i (ilev-1). +! baseprecv(ilev)%av(mld_sm_pr_t_) - The smoothed prolongator transpose. +! It maps vectors (ilev-1) ---> (ilev). +! baseprecv(ilev)%d - complex(psb_spk_), dimension(:), allocatable. +! The diagonal entries of the U factor in the ILU +! factorization of A(ilev). +! baseprecv(ilev)%desc_data - type(psb_desc_type). +! The communication descriptor associated to the base +! preconditioner, i.e. to the sparse matrices needed +! to apply the base preconditioner at the current level. +! baseprecv(ilev)%desc_ac - type(psb_desc_type). +! The communication descriptor associated to the sparse +! matrix A(ilev), stored in baseprecv(ilev)%av(mld_ac_). +! baseprecv(ilev)%iprcparm - integer, dimension(:), allocatable. +! The integer parameters defining the base +! preconditioner K(ilev). +! baseprecv(ilev)%rprcparm - complex(psb_spk_), dimension(:), allocatable. +! The real parameters defining the base preconditioner +! K(ilev). +! baseprecv(ilev)%perm - integer, dimension(:), allocatable. +! The row and column permutations applied to the local +! part of A(ilev) (defined only if baseprecv(ilev)% +! iprcparm(mld_sub_ren_)>0). +! baseprecv(ilev)%invperm - integer, dimension(:), allocatable. +! The inverse of the permutation stored in +! baseprecv(ilev)%perm. +! baseprecv(ilev)%mlia - integer, dimension(:), allocatable. +! The aggregation map (ilev-1) --> (ilev). +! In case of non-smoothed aggregation, it is used +! instead of mld_sm_pr_. +! baseprecv(ilev)%nlaggr - integer, dimension(:), allocatable. +! The number of aggregates (rows of A(ilev)) on the +! various processes. +! baseprecv(ilev)%base_a - type(psb_cspmat_type), pointer. +! Pointer (really a pointer!) to the base matrix of +! the current level, i.e. the local part of A(ilev); +! so we have a unified treatment of residuals. We +! need this to avoid passing explicitly the matrix +! A(ilev) to the routine which applies the +! preconditioner. +! baseprecv(ilev)%base_desc - type(psb_desc_type), pointer. +! Pointer to the communication descriptor associated +! to the sparse matrix pointed by base_a. +! baseprecv(ilev)%dorig - complex(psb_spk_), dimension(:), allocatable. +! Diagonal entries of the matrix pointed by base_a. +! +! x - complex(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - complex(psb_spk_), input. +! The scalar beta. +! y - complex(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! work - complex(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +! Note that when the LU factorization of the matrix A(ilev) is computed instead of +! the ILU one, by using UMFPACK or SuperLU, the corresponding L and U factors +! are stored in data structures provided by UMFPACK or SuperLU and pointed by +! baseprecv(ilev)%iprcparm(mld_umf_ptr) or baseprecv(ilev)%iprcparm(mld_slu_ptr), +! respectively. +! +subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cmlprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: baseprecv(:) + complex(psb_spk_),intent(in) :: alpha,beta + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: ictxt, np, me, err_act + integer :: debug_level, debug_unit + character(len=20) :: name + character :: trans_ + + name = 'mld_cmlprec_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + trans_ = psb_toupper(trans) + + select case(baseprecv(2)%iprcparm(mld_ml_type_)) + + case(mld_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(4001,name,a_err='mld_no_ml_ in mlprc_aply?') + goto 9999 + + case(mld_add_ml_) + ! + ! Additive multilevel + ! + + call add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + + case(mld_mult_ml_) + ! + ! Multiplicative multilevel (multiplicative among the levels, additive inside + ! each level) + ! + ! Pre/post-smoothing versions. + ! Note that the transpose switches pre <-> post. + ! + + select case(baseprecv(2)%iprcparm(mld_smooth_pos_)) + + case(mld_post_smooth_) + + select case (trans_) + case('N') + call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + case('T','C') + call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid trans') + goto 9999 + end select + + case(mld_pre_smooth_) + + select case (trans_) + case('N') + call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + case('T','C') + call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid trans') + goto 9999 + end select + + case(mld_twoside_smooth_) + + call mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + + case default + info = 4013 + call psb_errpush(info,name,a_err='invalid smooth_pos',& + & i_Err=(/baseprecv(2)%iprcparm(mld_smooth_pos_),0,0,0,0/)) + goto 9999 + + end select + + case default + info = 4013 + call psb_errpush(info,name,a_err='invalid mltype',& + & i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + ! + ! Subroutine: add_ml_aply + ! Version: complex + ! Note: internal subroutine of mld_dmlprec_aply. + ! + ! This routine computes + ! + ! Y = beta*Y + alpha*op(M^(-1))*X, + ! where + ! - M is an additive multilevel domain decomposition (Schwarz) preconditioner + ! associated to a certain matrix A and stored in the array baseprecv, + ! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to + ! the value of trans, + ! - X and Y are vectors, + ! - alpha and beta are scalars. + ! + ! The preconditioner M is additive both through the levels and inside each + ! level. + ! + ! For each level we have as many submatrices as processes (except for the coarsest + ! level where we might have a replicated index space) and each process takes care + ! of one submatrix. + ! + ! The multilevel preconditioner M is regarded as an array of 'base preconditioners', + ! each representing the part of the preconditioner associated to a certain level. + ! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev) + ! and is associated to a matrix A(ilev), obtained by 'tranferring' the original + ! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed + ! aggregation. + ! + ! The levels are numbered in increasing order starting from the finest one, i.e. + ! level 1 is the finest level and A(1) is the matrix A. + ! + ! For details on the additive multilevel Schwarz preconditioner see the + ! Algorithm 3.1.1 in the book: + ! B.F. Smith, P.E. Bjorstad & W.D. Gropp, + ! Domain decomposition: parallel multilevel methods for elliptic partial + ! differential equations, Cambridge University Press, 1996. + ! + ! For a description of the arguments see mld_dmlprec_aply. + ! + ! A sketch of the algorithm implemented in this routine is provided below + ! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to + ! level ilev-1, while AV(ilev; sm_pr_t_) denotes its transpose, i.e. the + ! corresponding restriction operator from level ilev-1 to level ilev). + ! + ! 1. ! Apply the base preconditioner at level 1. + ! ! The sum over the subdomains is carried out in the + ! ! application of K(1). + ! X(1) = Xest + ! Y(1) = (K(1)^(-1))*X(1) + ! + ! 2. DO ilev=2,nlev + ! + ! ! Transfer X(ilev-1) to the next coarser level. + ! X(ilev) = AV(ilev; sm_pr_t_)*X(ilev-1) + ! + ! ! Apply the base preconditioner at the current level. + ! ! The sum over the subdomains is carried out in the + ! ! application of K(ilev). + ! Y(ilev) = (K(ilev)^(-1))*X(ilev) + ! + ! ENDDO + ! + ! 3. DO ilev=nlev-1,1,-1 + ! + ! ! Transfer Y(ilev+1) to the next finer level. + ! Y(ilev) = AV(ilev+1; sm_pr_)*Y(ilev+1) + ! + ! ENDDO + ! + ! 4. Yext = beta*Yext + alpha*Y(1) + ! + subroutine add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: baseprecv(:) + complex(psb_spk_),intent(in) :: alpha,beta + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + integer :: ictxt,np,me,i, nr2l,nc2l,err_act + integer :: debug_level, debug_unit + integer :: ismth, nlev, ilev, icm + character(len=20) :: name + + type psb_mlprec_wrk_type + complex(psb_spk_), allocatable :: tx(:),ty(:),x2l(:),y2l(:) + end type psb_mlprec_wrk_type + type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + + name = 'add_ml_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + nlev = size(baseprecv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! + ! STEP 1 + ! + ! Apply the base preconditioner at the finest level + ! + allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)), stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/size(x)+size(y),0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + mlprec_wrk(1)%x2l(:) = x(:) + mlprec_wrk(1)%y2l(:) = czero + + + call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,& + & baseprecv(1)%base_desc,trans,work,info) + if (info /=0) then + call psb_errpush(4010,name,a_err='baseprec_aply') + goto 9999 + end if + ! + ! STEP 2 + ! + ! For each level except the finest one ... + ! + do ilev = 2, nlev + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + allocate(mlprec_wrk(ilev)%x2l(nc2l),mlprec_wrk(ilev)%y2l(nc2l),& + & stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + + ! Apply prolongator transpose, i.e. restriction + call psb_forward_map(cone,mlprec_wrk(ilev-1)%x2l,& + & czero,mlprec_wrk(ilev)%x2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + + if (icm == mld_repl_mat_) then + call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) + else if (icm /= mld_distr_mat_) then + info = 4013 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',& + & i_Err=(/icm,0,0,0,0/)) + goto 9999 + endif + + ! + ! Apply the base preconditioner + ! + call mld_baseprec_aply(cone,baseprecv(ilev),& + & mlprec_wrk(ilev)%x2l,czero,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev)%base_desc,trans,work,info) + + enddo + + ! + ! STEP 3 + ! + ! For each level except the finest one ... + ! + do ilev =nlev,2,-1 + + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + + ! + ! Apply prolongator + ! + call psb_backward_map(cone,mlprec_wrk(ilev)%y2l,& + & cone,mlprec_wrk(ilev-1)%y2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during prolongation') + goto 9999 + end if + end do + + ! + ! STEP 4 + ! + ! Compute the output vector Y + ! + call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,cone,y,baseprecv(1)%base_desc,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error on final update') + goto 9999 + end if + + deallocate(mlprec_wrk,stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine add_ml_aply + ! + ! Subroutine: mlt_pre_ml_aply + ! Version: complex + ! Note: internal subroutine of mld_dmlprec_aply. + ! + ! This routine computes + ! + ! Y = beta*Y + alpha*op(M^(-1))*X, + ! where + ! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner + ! associated to a certain matrix A and stored in the array baseprecv, + ! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to + ! the value of trans, + ! - X and Y are vectors, + ! - alpha and beta are scalars. + ! + ! The preconditioner M is hybrid in the sense that it is multiplicative through the + ! levels and additive inside a level; pre-smoothing only is applied at each level. + ! + ! For each level we have as many submatrices as processes (except for the coarsest + ! level where we might have a replicated index space) and each process takes care + ! of one submatrix. + ! + ! The multilevel preconditioner M is regarded as an array of 'base preconditioners', + ! each representing the part of the preconditioner associated to a certain level. + ! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev) + ! and is associated to a matrix A(ilev), obtained by 'tranferring' the original + ! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed + ! aggregation. + ! + ! The levels are numbered in increasing order starting from the finest one, i.e. + ! level 1 is the finest level and A(1) is the matrix A. + ! + ! For details on the pre-smoothed hybrid multiplicative multilevel Schwarz + ! preconditioner, see the Algorithm 3.2.1 in the book: + ! B.F. Smith, P.E. Bjorstad & W.D. Gropp, + ! Domain decomposition: parallel multilevel methods for elliptic partial + ! differential equations, Cambridge University Press, 1996. + ! + ! For a description of the arguments see mld_dmlprec_aply. + ! + ! A sketch of the algorithm implemented in this routine is provided below + ! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to + ! level ilev-1, while AV(ilev; sm_pr_t_) denotes its transpose, i.e. the + ! corresponding restriction operator from level ilev-1 to level ilev). + ! + ! 1. X(1) = Xext + ! + ! 2. ! Apply the base preconditioner at the finest level. + ! Y(1) = (K(1)^(-1))*X(1) + ! + ! 3. ! Compute the residual at the finest level. + ! TX(1) = X(1) - A(1)*Y(1) + ! + ! 4. DO ilev=2, nlev + ! + ! ! Transfer the residual to the current (coarser) level. + ! X(ilev) = AV(ilev; sm_pr_t_)*TX(ilev-1) + ! + ! ! Apply the base preconditioner at the current level. + ! ! The sum over the subdomains is carried out in the + ! ! application of K(ilev). + ! Y(ilev) = (K(ilev)^(-1))*X(ilev) + ! + ! ! Compute the residual at the current level (except at + ! ! the coarsest level). + ! IF (ilev < nlev) + ! TX(ilev) = (X(ilev)-A(ilev)*Y(ilev)) + ! + ! ENDDO + ! + ! 5. DO ilev=nlev-1,1,-1 + ! + ! ! Transfer Y(ilev+1) to the next finer level + ! Y(ilev) = Y(ilev) + AV(ilev+1; sm_pr_)*Y(ilev+1) + ! + ! ENDDO + ! + ! 6. Yext = beta*Yext + alpha*Y(1) + ! + ! + subroutine mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: baseprecv(:) + complex(psb_spk_),intent(in) :: alpha,beta + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + integer :: ictxt,np,me,i, nr2l,nc2l,err_act + integer :: debug_level, debug_unit + integer :: ismth, nlev, ilev, icm + character(len=20) :: name + + type psb_mlprec_wrk_type + complex(psb_spk_), allocatable :: tx(:),ty(:),x2l(:),y2l(:) + end type psb_mlprec_wrk_type + type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + + name = 'mlt_pre_ml_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + nlev = size(baseprecv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! + ! STEP 1 + ! + ! Copy the input vector X + ! + n_col = psb_cd_get_local_cols(desc_data) + nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc) + + allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), & + & mlprec_wrk(1)%tx(nc2l), stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + mlprec_wrk(1)%x2l(:) = x + ! + ! STEP 2 + ! + ! Apply the base preconditioner at the finest level + ! + call mld_baseprec_aply(cone,baseprecv(1),mlprec_wrk(1)%x2l,& + & czero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,& + & trans,work,info) + if (info /=0) then + call psb_errpush(4010,name,a_err=' baseprec_aply') + goto 9999 + end if + + ! + ! STEP 3 + ! + ! Compute the residual at the finest level + ! + mlprec_wrk(1)%tx = mlprec_wrk(1)%x2l + + call psb_spmm(-cone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,& + & cone,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,& + & work=work,trans=trans) + if (info /=0) then + call psb_errpush(4001,name,a_err=' fine level residual') + goto 9999 + end if + + ! + ! STEP 4 + ! + ! For each level but the finest one ... + ! + do ilev = 2, nlev + + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + + allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),& + & mlprec_wrk(ilev)%x2l(nc2l), stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + ! Apply prolongator transpose, i.e. restriction + call psb_forward_map(cone,mlprec_wrk(ilev-1)%tx,& + & czero,mlprec_wrk(ilev)%x2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + if (icm ==mld_repl_mat_) then + call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) + else if (icm /= mld_distr_mat_) then + info = 4013 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',& + & i_Err=(/icm,0,0,0,0/)) + goto 9999 + endif + + ! + ! Apply the base preconditioner + ! + call mld_baseprec_aply(cone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,& + & czero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info) + + ! + ! Compute the residual (at all levels but the coarsest one) + ! + if (ilev < nlev) then + mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l + if (info == 0) call psb_spmm(-cone,baseprecv(ilev)%base_a,& + & mlprec_wrk(ilev)%y2l,cone,mlprec_wrk(ilev)%tx,& + & baseprecv(ilev)%base_desc,info,work=work,trans=trans) + endif + if (info /=0) then + call psb_errpush(4001,name,a_err='Error on up sweep residual') + goto 9999 + end if + enddo + + ! + ! STEP 5 + ! + ! For each level but the coarsest one ... + ! + do ilev = nlev-1, 1, -1 + + ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_) + n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + + ! + ! Apply prolongator + ! + call psb_backward_map(cone,mlprec_wrk(ilev+1)%y2l,& + & cone,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev+1)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during prolongation') + goto 9999 + end if + enddo + + ! + ! STEP 6 + ! + ! Compute the output vector Y + ! + call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,& + & baseprecv(1)%base_desc,info) + if (info /=0) then + call psb_errpush(4001,name,a_err='Error on final update') + goto 9999 + end if + + deallocate(mlprec_wrk,stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mlt_pre_ml_aply + ! + ! Subroutine: mlt_post_ml_aply + ! Version: complex + ! Note: internal subroutine of mld_dmlprec_aply. + ! + ! This routine computes + ! + ! Y = beta*Y + alpha*op(M^(-1))*X, + ! where + ! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner + ! associated to a certain matrix A and stored in the array baseprecv, + ! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to + ! the value of trans, + ! - X and Y are vectors, + ! - alpha and beta are scalars. + ! + ! The preconditioner M is hybrid in the sense that it is multiplicative through the + ! levels and additive inside a level; post-smoothing only is applied at each level. + ! + ! For each level we have as many submatrices as processes (except for the coarsest + ! level where we might have a replicated index space) and each process takes care + ! of one submatrix. + ! + ! The multilevel preconditioner M is regarded as an array of 'base preconditioners', + ! each representing the part of the preconditioner associated to a certain level. + ! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev) + ! and is associated to a matrix A(ilev), obtained by 'tranferring' the original + ! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed + ! aggregation. + ! + ! The levels are numbered in increasing order starting from the finest one, i.e. + ! level 1 is the finest level and A(1) is the matrix A. + ! + ! For details on hybrid multiplicative multilevel Schwarz preconditioners, see + ! B.F. Smith, P.E. Bjorstad & W.D. Gropp, + ! Domain decomposition: parallel multilevel methods for elliptic partial + ! differential equations, Cambridge University Press, 1996. + ! + ! For a description of the arguments see mld_dmlprec_aply. + ! + ! A sketch of the algorithm implemented in this routine is provided below. + ! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to + ! level ilev-1, while AV(ilev; sm_pr_t_) denotes its transpose, i.e. the + ! corresponding restriction operator from level ilev-1 to level ilev). + ! + ! 1. X(1) = Xext + ! + ! 2. DO ilev=2, nlev + ! + ! ! Transfer X(ilev-1) to the next coarser level. + ! X(ilev) = AV(ilev; sm_pr_t_)*X(ilev-1) + ! + ! ENDDO + ! + ! 3.! Apply the preconditioner at the coarsest level. + ! Y(nlev) = (K(nlev)^(-1))*X(nlev) + ! + ! 4. DO ilev=nlev-1,1,-1 + ! + ! ! Transfer Y(ilev+1) to the next finer level. + ! Y(ilev) = AV(ilev+1; sm_pr_)*Y(ilev+1) + ! + ! ! Compute the residual at the current level and apply to it the + ! ! base preconditioner. The sum over the subdomains is carried out + ! ! in the application of K(ilev). + ! Y(ilev) = Y(ilev) + (K(ilev)^(-1))*(X(ilev)-A(ilev)*Y(ilev)) + ! + ! ENDDO + ! + ! 5. Yext = beta*Yext + alpha*Y(1) + ! + ! + subroutine mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: baseprecv(:) + complex(psb_spk_),intent(in) :: alpha,beta + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + integer :: ictxt,np,me,i, nr2l,nc2l,err_act + integer :: debug_level, debug_unit + integer :: ismth, nlev, ilev, icm + character(len=20) :: name + + type psb_mlprec_wrk_type + complex(psb_spk_), allocatable :: tx(:),ty(:),x2l(:),y2l(:) + end type psb_mlprec_wrk_type + type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + + name = 'mlt_post_ml_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + nlev = size(baseprecv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! + ! STEP 1 + ! + ! Copy the input vector X + ! + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' desc_data status',allocated(desc_data%matrix_data) + + n_col = psb_cd_get_local_cols(desc_data) + nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc) + + allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), & + & mlprec_wrk(1)%tx(nc2l), stat=info) + + call psb_geaxpby(cone,x,czero,mlprec_wrk(1)%tx,& + & baseprecv(1)%base_desc,info) + call psb_geaxpby(cone,x,czero,mlprec_wrk(1)%x2l,& + & baseprecv(1)%base_desc,info) + + ! + ! STEP 2 + ! + ! For each level but the finest one ... + ! + do ilev=2, nlev + + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name), & + & ' starting up sweep ',& + & ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,& + & nc2l, nr2l,ismth + + allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),& + & mlprec_wrk(ilev)%x2l(nc2l), stat=info) + + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + ! Apply prolongator transpose, i.e. restriction + call psb_forward_map(cone,mlprec_wrk(ilev-1)%x2l,& + & czero,mlprec_wrk(ilev)%x2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + if (icm == mld_repl_mat_) Then + call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) + else if (icm /= mld_distr_mat_) Then + info = 4013 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',& + & i_Err=(/icm,0,0,0,0/)) + goto 9999 + endif + + ! + ! update x2l + ! + call psb_geaxpby(cone,mlprec_wrk(ilev)%x2l,czero,mlprec_wrk(ilev)%tx,& + & baseprecv(ilev)%base_desc,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error in update') + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done up sweep ', ilev + + enddo + + ! + ! STEP 3 + ! + ! Apply the base preconditioner at the coarsest level + ! + call mld_baseprec_aply(cone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, & + & czero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%base_desc,trans,work,info) + if (info /=0) then + call psb_errpush(4010,name,a_err='baseprec_aply') + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) write(debug_unit,*) & + & me,' ',trim(name), ' done baseprec_aply ', nlev + + ! + ! STEP 4 + ! + ! For each level but the coarsest one ... + ! + do ilev=nlev-1, 1, -1 + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' starting down sweep',ilev + + ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_) + n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + + ! + ! Apply prolongator + ! + call psb_backward_map(cone,mlprec_wrk(ilev+1)%y2l,& + & czero,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev+1)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during prolongation') + goto 9999 + end if + + ! + ! Compute the residual + ! + call psb_spmm(-cone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& + & cone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,& + & work=work,trans=trans) + + ! + ! Apply the base preconditioner + ! + if (info == 0) call mld_baseprec_aply(cone,baseprecv(ilev),mlprec_wrk(ilev)%tx,& + & cone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info) + if (info /=0) then + call psb_errpush(4001,name,a_err=' spmm/baseprec_aply') + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done down sweep',ilev + enddo + + ! + ! STEP 5 + ! + ! Compute the output vector Y + ! + call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info) + + if (info /=0) then + call psb_errpush(4001,name,a_err=' Final update') + goto 9999 + end if + + + + deallocate(mlprec_wrk,stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mlt_post_ml_aply + ! + ! Subroutine: mlt_twoside_ml_aply + ! Version: complex + ! Note: internal subroutine of mld_dmlprec_aply. + ! + ! This routine computes + ! + ! Y = beta*Y + alpha*op(M^(-1))*X, + ! where + ! - M is a symmetrized hybrid multilevel domain decomposition (Schwarz) + ! preconditioner associated to a certain matrix A and stored in the array + ! baseprecv, + ! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to + ! the value of trans, + ! - X and Y are vectors, + ! - alpha and beta are scalars. + ! + ! The preconditioner M is hybrid in the sense that it is multiplicative through + ! the levels and additive inside a level; it is symmetrized since pre-smoothing + ! and post-smoothing are applied at each level. + ! + ! For each level we have as many submatrices as processes (except for the coarsest + ! level where we might have a replicated index space) and each process takes care + ! of one submatrix. + ! + ! The multilevel preconditioner M is regarded as an array of 'base preconditioners', + ! each representing the part of the preconditioner associated to a certain level. + ! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev) + ! and is associated to a matrix A(ilev), obtained by 'tranferring' the original + ! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed + ! aggregation. + ! + ! The levels are numbered in increasing order starting from the finest one, i.e. + ! level 1 is the finest level and A(1) is the matrix A. + ! + ! For details on the symmetrized hybrid multiplicative multilevel Schwarz + ! preconditioner, see the Algorithm 3.2.2 of the book: + ! B.F. Smith, P.E. Bjorstad & W.D. Gropp, + ! Domain decomposition: parallel multilevel methods for elliptic partial + ! differential equations, Cambridge University Press, 1996. + ! + ! For a description of the arguments see mld_dmlprec_aply. + ! + ! A sketch of the algorithm implemented in this routine is provided below. + ! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to + ! level ilev-1, while AV(ilev; sm_pr_t_) denotes its transpose, i.e. the + ! corresponding restriction operator from level ilev-1 to level ilev). + ! + ! 1. X(1) = Xext + ! + ! 2. ! Apply the base peconditioner at the finest level + ! Y(1) = (K(1)^(-1))*X(1) + ! + ! 3. ! Compute the residual at the finest level + ! TX(1) = X(1) - A(1)*Y(1) + ! + ! 4. DO ilev=2, nlev + ! + ! ! Transfer the residual to the current (coarser) level + ! X(ilev) = AV(ilev; sm_pr_t)*TX(ilev-1) + ! + ! ! Apply the base preconditioner at the current level. + ! ! The sum over the subdomains is carried out in the + ! ! application of K(ilev) + ! Y(ilev) = (K(ilev)^(-1))*X(ilev) + ! + ! ! Compute the residual at the current level + ! TX(ilev) = (X(ilev)-A(ilev)*Y(ilev)) + ! + ! ENDDO + ! + ! 5. DO ilev=NLEV-1,1,-1 + ! + ! ! Transfer Y(ilev+1) to the next finer level + ! Y(ilev) = Y(ilev) + AV(ilev+1; sm_pr_)*Y(ilev+1) + ! + ! ! Compute the residual at the current level and apply to it the + ! ! base preconditioner. The sum over the subdomains is carried out + ! ! in the application of K(ilev) + ! Y(ilev) = Y(ilev) + (K(ilev)**(-1))*(X(ilev)-A(ilev)*Y(ilev)) + ! + ! ENDDO + ! + ! 6. Yext = beta*Yext + alpha*Y(1) + ! + subroutine mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: baseprecv(:) + complex(psb_spk_),intent(in) :: alpha,beta + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + integer :: ictxt,np,me,i, nr2l,nc2l,err_act + integer :: debug_level, debug_unit + integer :: ismth, nlev, ilev, icm + character(len=20) :: name + + type psb_mlprec_wrk_type + complex(psb_spk_), allocatable :: tx(:),ty(:),x2l(:),y2l(:) + end type psb_mlprec_wrk_type + type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + + name = 'mlt_twoside_ml_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + nlev = size(baseprecv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! STEP 1 + ! + ! Copy the input vector X + ! + n_col = psb_cd_get_local_cols(desc_data) + nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc) + + allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), & + & mlprec_wrk(1)%ty(nc2l), mlprec_wrk(1)%tx(nc2l), stat=info) + + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + call psb_geaxpby(cone,x,czero,mlprec_wrk(1)%x2l,& + & baseprecv(1)%base_desc,info) + call psb_geaxpby(cone,x,czero,mlprec_wrk(1)%tx,& + & baseprecv(1)%base_desc,info) + + ! + ! STEP 2 + ! + ! Apply the base preconditioner at the finest level + ! + call mld_baseprec_aply(cone,baseprecv(1),mlprec_wrk(1)%x2l,& + & czero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,& + & trans,work,info) + ! + ! STEP 3 + ! + ! Compute the residual at the finest level + ! + mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l + if (info == 0) call psb_spmm(-cone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,& + & cone,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,& + & work=work,trans=trans) + if (info /=0) then + call psb_errpush(4010,name,a_err='Fine level baseprec/residual') + goto 9999 + end if + + ! + ! STEP 4 + ! + ! For each level but the finest one ... + ! + do ilev = 2, nlev + + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%ty(nc2l),& + & mlprec_wrk(ilev)%y2l(nc2l),mlprec_wrk(ilev)%x2l(nc2l), stat=info) + + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + ! Apply prolongator transpose, i.e. restriction + call psb_forward_map(cone,mlprec_wrk(ilev-1)%ty,& + & czero,mlprec_wrk(ilev)%x2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + if (icm == mld_repl_mat_) then + call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) + else if (icm /= mld_distr_mat_) then + info = 4013 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',& + & i_Err=(/icm,0,0,0,0/)) + goto 9999 + endif + + call psb_geaxpby(cone,mlprec_wrk(ilev)%x2l,czero,mlprec_wrk(ilev)%tx,& + & baseprecv(ilev)%base_desc,info) + ! + ! Apply the base preconditioner + ! + if (info == 0) call mld_baseprec_aply(cone,baseprecv(ilev),& + & mlprec_wrk(ilev)%x2l,czero,mlprec_wrk(ilev)%y2l,& + &baseprecv(ilev)%base_desc,trans,work,info) + ! + ! Compute the residual (at all levels but the coarsest one) + ! + if(ilev < nlev) then + mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l + if (info == 0) call psb_spmm(-cone,baseprecv(ilev)%base_a,& + & mlprec_wrk(ilev)%y2l,cone,mlprec_wrk(ilev)%ty,& + & baseprecv(ilev)%base_desc,info,work=work,trans=trans) + endif + if (info /=0) then + call psb_errpush(4001,name,a_err='baseprec_aply/residual') + goto 9999 + end if + + enddo + + ! + ! STEP 5 + ! + ! For each level but the coarsest one ... + ! + do ilev=nlev-1, 1, -1 + + ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_) + n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + + ! + ! Apply prolongator + ! + call psb_backward_map(cone,mlprec_wrk(ilev+1)%y2l,& + & cone,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev+1)%map_desc,info,work=work) + + if (info /=0 ) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + ! + ! Compute the residual + ! + call psb_spmm(-cone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& + & cone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,& + & work=work,trans=trans) + ! + ! Apply the base preconditioner + ! + if (info == 0) call mld_baseprec_aply(cone,baseprecv(ilev),mlprec_wrk(ilev)%tx,& + & cone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error: residual/baseprec_aply') + goto 9999 + end if + enddo + + ! + ! STEP 6 + ! + ! Compute the output vector Y + ! + call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,& + & baseprecv(1)%base_desc,info) + + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error final update') + goto 9999 + end if + + + + deallocate(mlprec_wrk,stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mlt_twoside_ml_aply + +end subroutine mld_cmlprec_aply + diff --git a/mlprec/mld_cmlprec_bld.f90 b/mlprec/mld_cmlprec_bld.f90 new file mode 100644 index 00000000..b164f37c --- /dev/null +++ b/mlprec/mld_cmlprec_bld.f90 @@ -0,0 +1,180 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cmlprec_bld.f90 +! +! Subroutine: mld_cmlprec_bld +! Version: complex +! +! This routine builds the base preconditioner corresponding to the current +! level of the multilevel preconditioner. The routine first builds the +! (coarse) matrix associated to the current level from the (fine) matrix +! associated to the previous level, then builds the related base preconditioner. +! +! +! Arguments: +! a - type(psb_cspmat_type). +! The sparse matrix structure containing the local part of the +! matrix to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_cbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_cmlprec_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cmlprec_bld + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_cbaseprc_type), intent(inout),target :: p + integer, intent(out) :: info + + ! Local variables + type(psb_desc_type) :: desc_ac + type(psb_cspmat_type) :: ac + character(len=20) :: name + integer :: ictxt, np, me, err_act + + name='mld_cmlprec_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + info = 0 + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) + + if (.not.allocated(p%iprcparm)) then + info = 2222 + call psb_errpush(info,name) + goto 9999 + endif + call mld_check_def(p%iprcparm(mld_ml_type_),'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%iprcparm(mld_aggr_alg_),'Aggregation',& + & mld_dec_aggr_,is_legal_ml_aggr_alg) + call mld_check_def(p%iprcparm(mld_aggr_kind_),'Smoother',& + & mld_smooth_prol_,is_legal_ml_aggr_kind) + call mld_check_def(p%iprcparm(mld_coarse_mat_),'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + call mld_check_def(p%iprcparm(mld_smooth_pos_),'smooth_pos',& + & mld_pre_smooth_,is_legal_ml_smooth_pos) + + + select case(p%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_) + call mld_check_def(p%iprcparm(mld_sub_fill_in_),'Level',0,is_legal_ml_lev) + case(mld_ilu_t_) + call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',szero,is_legal_s_fact_thrs) + end select + call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',szero,is_legal_s_omega) + call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',& + & 1,is_legal_jac_sweeps) + + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + ! + ! Build the coarse-level matrix from the fine level one, starting from + ! the mapping defined by mld_aggrmap_bld and applying the aggregation + ! algorithm specified by p%iprcparm(mld_aggr_kind_) + ! + call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_aggrmat_asb') + goto 9999 + end if + + ! + ! Build the 'base preconditioner' corresponding to the coarse level + ! + call mld_baseprc_bld(ac,desc_ac,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_baseprc_bld') + goto 9999 + end if + + ! + ! We have used a separate ac because + ! 1. we want to reuse the same routines mld_ilu_bld, etc., + ! 2. we do NOT want to pass an argument twice to them (p%av(mld_ac_) and p), + ! as this would violate the Fortran standard. + ! Hence a separate AC and a TRANSFER function at the end. + ! + call psb_sp_transfer(ac,p%av(mld_ac_),info) + p%base_a => p%av(mld_ac_) + if (info==0) call psb_cdtransfer(desc_ac,p%desc_ac,info) + + p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,& + & p%desc_ac,p%av(mld_sm_pr_t_),p%av(mld_sm_pr_)) + ! The two matrices from p%av() have been copied, may free them. + if (info == 0) call psb_sp_free(p%av(mld_sm_pr_t_),info) + if (info == 0) call psb_sp_free(p%av(mld_sm_pr_),info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdtransfer') + goto 9999 + end if + p%base_desc => p%desc_ac + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + Return + +end subroutine mld_cmlprec_bld diff --git a/mlprec/mld_cprec_aply.f90 b/mlprec/mld_cprec_aply.f90 new file mode 100644 index 00000000..7d85c17d --- /dev/null +++ b/mlprec/mld_cprec_aply.f90 @@ -0,0 +1,261 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cprec_aply.f90 +! +! Subroutine: mld_cprec_aply +! Version: complex +! +! This routine applies the preconditioner built by mld_cprecbld, i.e. it computes +! +! Y = op(M^(-1)) * X, +! where +! - M is the preconditioner, +! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors. +! This operation is performed at each iteration of a preconditioned Krylov solver. +! +! +! Arguments: +! prec - type(mld_cprec_type), input. +! The preconditioner data structure containing the local part +! of the preconditioner to be applied. +! x - complex(psb_spk_), dimension(:), input. +! The local part of the vector X in Y := op(M^(-1)) * X. +! y - complex(psb_spk_), dimension(:), output. +! The local part of the vector Y in Y := op(M^(-1)) * X. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! info - integer, output. +! Error code. +! trans - character(len=1), optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! work - complex(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at +! least 4*psb_cd_get_local_cols(desc_data). +! +subroutine mld_cprec_aply(prec,x,y,desc_data,info,trans,work) + + use psb_base_mod + use mld_inner_mod + use mld_prec_mod, mld_protect_name => mld_cprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_), optional, target :: work(:) + + ! Local variables + character :: trans_ + complex(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act,iwsz + character(len=20) :: name + + name='mld_cprec_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + iwsz = max(1,4*psb_cd_get_local_cols(desc_data)) + allocate(work_(iwsz),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/iwsz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + end if + + if (.not.(allocated(prec%baseprecv))) then + !! Error 1: should call mld_dprecbld + info=3112 + call psb_errpush(info,name) + goto 9999 + end if + if (size(prec%baseprecv) >1) then + call mld_mlprec_aply(cone,prec%baseprecv,x,czero,y,desc_data,trans_,work_,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_cmlprec_aply') + goto 9999 + end if + + else if (size(prec%baseprecv) == 1) then + call mld_baseprec_aply(cone,prec%baseprecv(1),x,czero,y,desc_data,trans_, work_,info) + else + info = 4013 + call psb_errpush(info,name,a_err='Invalid size of baseprecv',& + & i_Err=(/size(prec%baseprecv),0,0,0,0/)) + goto 9999 + endif + + ! If the original distribution has an overlap we should fix that. + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + + if (present(work)) then + else + deallocate(work_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cprec_aply + + +! File: mld_cprec_aply.f90. +! +! Subroutine: mld_cprec_aply1. +! Version: complex. +! +! Applies the preconditioner built by mld_cprecbld, i.e. computes +! +! X = op(M^(-1)) * X, +! where +! - M is the preconditioner, +! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans, +! - X is a vectors. +! This operation is performed at each iteration of a preconditioned Krylov solver. +! +! This routine differs from mld_cprec_aply because the preconditioned vector X +! overwrites the original one. +! +! +! Arguments: +! prec - type(mld_cprec_type), input. +! The preconditioner data structure containing the local part +! of the preconditioner to be applied. +! x - complex(psb_spk_), dimension(:), input/output. +! The local part of vector X in X := op(M^(-1)) * X. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! info - integer, output. +! Error code. +! trans - character(len=1), optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! +subroutine mld_cprec_aply1(prec,x,desc_data,info,trans) + + use psb_base_mod + use mld_inner_mod + use mld_prec_mod, mld_protect_name => mld_cprec_aply1 + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + + ! Local variables + integer :: ictxt,np,me, err_act + complex(psb_spk_), pointer :: WW(:), w1(:) + character(len=20) :: name + + name='mld_cprec_aply1' + info = 0 + call psb_erractionsave(err_act) + + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*size(x),0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + call mld_precaply(prec,x,ww,desc_data,info,trans=trans,work=w1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_precaply') + goto 9999 + end if + + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine mld_cprec_aply1 diff --git a/mlprec/mld_cprecbld.f90 b/mlprec/mld_cprecbld.f90 new file mode 100644 index 00000000..5e8847b1 --- /dev/null +++ b/mlprec/mld_cprecbld.f90 @@ -0,0 +1,234 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cprecbld.f90 +! +! Subroutine: mld_cprecbld +! Version: complex +! Contains: subroutine init_baseprc_av +! +! This routine builds the preconditioner according to the requirements made by +! the user trough the subroutines mld_precinit and mld_precset. +! +! A multilevel preconditioner is regarded as an array of 'base preconditioners', +! each representing the part of the preconditioner associated to a certain level. +! The levels are numbered in increasing order starting from the finest one, i.e. +! level 1 is the finest level. +! +! +! Arguments: +! a - type(psb_cspmat_type). +! The sparse matrix structure containing the local part of the +! matrix to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure containing the local part +! of the preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_cprecbld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod + use mld_prec_mod, mld_protect_name => mld_cprecbld + Implicit None + + ! Arguments + type(psb_cspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_cprec_type),intent(inout) :: p + integer, intent(out) :: info +!!$ character, intent(in), optional :: upd + + + ! Local Variables + Integer :: err,i,k,ictxt, me,np, err_act, iszv + integer :: int_err(5) + character :: upd_ + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info=0 + err=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + name = 'mld_cprecbld' + info = 0 + int_err(1) = 0 + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Entering ',desc_a%matrix_data(:) + ! + ! For the time being we are commenting out the UPDATE argument + ! we plan to resurrect it later. +!!$ if (present(upd)) then +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd +!!$ +!!$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then +!!$ upd_=psb_toupper(upd) +!!$ else +!!$ upd_='F' +!!$ endif +!!$ else +!!$ upd_='F' +!!$ endif + upd_ = 'F' + + if (.not.allocated(p%baseprecv)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + ! + ! Check to ensure all procs have the same + ! + iszv = size(p%baseprecv) + call psb_bcast(ictxt,iszv) + if (iszv /= size(p%baseprecv)) then + info=4001 + call psb_errpush(info,name,a_err='Inconsistent size of baseprecv') + goto 9999 + end if + + if (iszv >= 1) then + ! + ! Allocate and build the fine level preconditioner + ! + call init_baseprc_av(p%baseprecv(1),info) + if (info == 0) call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,upd_) + + if (info /= 0) then + call psb_errpush(4001,name,a_err='Base level precbuild.') + goto 9999 + end if + + else + info=4010 + ch_err='size bpv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (iszv > 1) then + + ! + ! Build the base preconditioners corresponding to the remaining + ! levels + ! + do i=2, iszv + + ! + ! Allocate the av component of the preconditioner data type + ! at level i + ! + if (i= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + + ! + ! Build the base preconditioner corresponding to level i + ! + if (info == 0) call mld_mlprec_bld(p%baseprecv(i-1)%base_a,& + & p%baseprecv(i-1)%base_desc, p%baseprecv(i),info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Init & build upper level preconditioner') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + end do + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine init_baseprc_av(p,info) + type(mld_cbaseprc_type), intent(inout) :: p + integer :: info + if (allocated(p%av)) then + if (size(p%av) /= mld_max_avsz_) then + deallocate(p%av,stat=info) + if (info /= 0) return + endif + end if + if (.not.(allocated(p%av))) then + allocate(p%av(mld_max_avsz_),stat=info) + if (info /= 0) return + end if + do k=1,size(p%av) + call psb_nullify_sp(p%av(k)) + end do + + end subroutine init_baseprc_av + +end subroutine mld_cprecbld + diff --git a/mlprec/mld_cprecfree.f90 b/mlprec/mld_cprecfree.f90 new file mode 100644 index 00000000..b9ee2c15 --- /dev/null +++ b/mlprec/mld_cprecfree.f90 @@ -0,0 +1,94 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cprecfree.f90 +! +! Subroutine: mld_cprecfree +! Version: real +! +! This routine deallocates the preconditioner data structure. +! +! +! Arguments: +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure to be deallocated. +! info - integer, output. +! Error code. +! +subroutine mld_cprecfree(p,info) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_cprecfree + + implicit none + + ! Arguments + type(mld_cprec_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: me,err_act,i + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=0 + name = 'mld_cprecfree' + call psb_erractionsave(err_act) + + me=-1 + + if (allocated(p%baseprecv)) then + do i=1,size(p%baseprecv) + call mld_base_precfree(p%baseprecv(i),info) + end do + deallocate(p%baseprecv) + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cprecfree diff --git a/mlprec/mld_cprecinit.f90 b/mlprec/mld_cprecinit.f90 new file mode 100644 index 00000000..d8d0e3a4 --- /dev/null +++ b/mlprec/mld_cprecinit.f90 @@ -0,0 +1,252 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cprecinit.f90 +! +! Subroutine: mld_cprecinit +! Version: complex +! +! This routine allocates and initializes the preconditioner data structure, +! according to the preconditioner type chosen by the user. +! +! A default preconditioner is set for each preconditioner type +! specified by the user: +! +! 'NONE', 'NOPREC' - no preconditioner +! +! 'DIAG' - diagonal preconditioner +! +! 'BJAC' - block Jacobi preconditioner, with ILU(0) +! on the local blocks +! +! 'AS' - Restricted Additive Schwarz (RAS), with +! overlap 1 and ILU(0) on the local submatrices +! +! 'ML' - Multilevel hybrid preconditioner (additive on the +! same level and multiplicative through the levels), +! with nlev levels and post-smoothing only. The block +! Jacobi preconditioner, with ILU(0) on the local +! blocks, is applied as post-smoother at each level +! but the coarsest one; four sweeps of the block-Jacobi +! solver, with ILU(0) on the blocks, are applied at +! the coarsest level, on the distributed coarse matrix. +! +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! +! Arguments: +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure. +! ptype - character(len=*), input. +! The type of preconditioner. Its values are 'NONE', +! 'NOPREC', 'DIAG', 'BJAC', 'AS', 'ML' (and the corresponding +! lowercase strings). +! info - integer, output. +! Error code. +! nlev - integer, optional, input. +! The number of levels of the multilevel preconditioner. +! If nlev is not present and ptype='ML', then nlev=2 +! is assumed. If ptype/='ML', nlev is ignored. +! +subroutine mld_cprecinit(p,ptype,info,nlev) + + use psb_base_mod + use mld_prec_mod, psb_protect_name => mld_cprecinit + + implicit none + +! Arguments + type(mld_cprec_type), intent(inout) :: p + character(len=*), intent(in) :: ptype + integer, intent(out) :: info + integer, optional, intent(in) :: nlev + +! Local variables + integer :: nlev_, ilev_ + character(len=*), parameter :: name='mld_precinit' + info = 0 + + if (allocated(p%baseprecv)) then + call mld_precfree(p,info) + if (info /=0) then + ! Do we want to do something? + endif + endif + + select case(psb_toupper(ptype(1:len_trim(ptype)))) + case ('NONE','NOPREC') + nlev_ = 1 + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_noprec_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + + case ('DIAG') + nlev_ = 1 + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_diag_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + + case ('BJAC') + nlev_ = 1 + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + + case ('AS') + nlev_ = 1 + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 1 + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + + + case ('ML') + + if (present(nlev)) then + nlev_ = max(1,nlev) + else + nlev_ = 2 + end if + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + if (nlev_ == 1) return + + do ilev_ = 2, nlev_ -1 + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_ + p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_ + p%baseprecv(ilev_)%iprcparm(mld_smooth_pos_) = mld_post_smooth_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + p%baseprecv(ilev_)%rprcparm(mld_aggr_damp_) = 4.e0/3.e0 + end do + ilev_ = nlev_ + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_ + p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_ + p%baseprecv(ilev_)%iprcparm(mld_smooth_pos_) = mld_post_smooth_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 4 + p%baseprecv(ilev_)%rprcparm(mld_aggr_damp_) = 4.e0/3.e0 + + case default + write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"' + info = 2 + + end select + + +end subroutine mld_cprecinit diff --git a/mlprec/mld_cprecset.f90 b/mlprec/mld_cprecset.f90 new file mode 100644 index 00000000..0822bc02 --- /dev/null +++ b/mlprec/mld_cprecset.f90 @@ -0,0 +1,637 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cprecset.f90 +! +! Subroutine: mld_cprecseti +! Version: complex +! +! This routine sets the integer parameters defining the preconditioner. More +! precisely, the integer parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set character and real parameters, see mld_cprecsetc and mld_cprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in MLD2P4 user's guide. +! val - integer, input. +! The value of the parameter to be set. The list of allowed +! values is reported in MLD2P4 user's guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +subroutine mld_cprecseti(p,what,val,info,ilev) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_cprecseti + + implicit none + +! Arguments + type(mld_cprec_type), intent(inout) :: p + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + +! Local variables + integer :: ilev_, nlev_ + character(len=*), parameter :: name='mld_precseti' + + info = 0 + + if (.not.allocated(p%baseprecv)) then + info = 3111 + write(0,*) name,': Error: Uninitialized preconditioner, should call MLD_PRECINIT' + return + endif + nlev_ = size(p%baseprecv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + info = -1 + write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + return + endif + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + info = 3111 + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_n_ovr_,mld_sub_fill_in_,mld_smooth_sweeps_) + p%baseprecv(ilev_)%iprcparm(what) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + else if (ilev_ > 1) then + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_n_ovr_,mld_sub_fill_in_,& + & mld_smooth_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + & mld_smooth_pos_,mld_aggr_eig_) + p%baseprecv(ilev_)%iprcparm(what) = val + case(mld_coarse_mat_) + if (ilev_ /= nlev_ .and. val /= mld_distr_mat_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = val + case(mld_coarse_solve_) + if (ilev_ /= nlev_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = val + case(mld_coarse_sweeps_) + if (ilev_ /= nlev_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = val + case(mld_coarse_fill_in_) + if (ilev_ /= nlev_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate + ! levels + ! + + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_n_ovr_,mld_sub_fill_in_,& + & mld_smooth_sweeps_) + do ilev_=1,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%iprcparm(what) = val + end do + case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + & mld_smooth_pos_,mld_aggr_eig_) + do ilev_=2,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%iprcparm(what) = val + end do + case(mld_coarse_mat_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = val + case(mld_coarse_solve_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val + case(mld_coarse_sweeps_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_smooth_sweeps_) = val + case(mld_coarse_fill_in_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_fill_in_) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + endif + +end subroutine mld_cprecseti + +! +! Subroutine: mld_cprecsetc +! Version: complex +! Contains: get_stringval +! +! This routine sets the character parameters defining the preconditioner. More +! precisely, the character parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and real parameters, see mld_cprecseti and mld_cprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in MLD2P4 user's guide. +! string - character(len=*), input. +! The value of the parameter to be set. The list of allowed +! values is reported in MLD2P4 user's guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +subroutine mld_cprecsetc(p,what,string,info,ilev) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_cprecsetc + + implicit none + + ! Arguments + type(mld_cprec_type), intent(inout) :: p + integer, intent(in) :: what + character(len=*), intent(in) :: string + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + +! Local variables + integer :: ilev_, nlev_,val + character(len=*), parameter :: name='mld_precseti' + + info = 0 + + if (.not.allocated(p%baseprecv)) then + info = 3111 + return + endif + nlev_ = size(p%baseprecv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + info = -1 + return + endif + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = 3111 + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_) + call get_stringval(string,val,info) + p%baseprecv(ilev_)%iprcparm(what) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + else if (ilev_ > 1) then + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + & mld_smooth_pos_,mld_aggr_eig_) + call get_stringval(string,val,info) + p%baseprecv(ilev_)%iprcparm(what) = val + case(mld_coarse_mat_) + call get_stringval(string,val,info) + if (ilev_ /= nlev_ .and. val /= mld_distr_mat_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = val + case(mld_coarse_solve_) + call get_stringval(string,val,info) + if (ilev_ /= nlev_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate + ! levels + ! + + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_) + call get_stringval(string,val,info) + do ilev_=1,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%iprcparm(what) = val + end do + case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + & mld_smooth_pos_) + call get_stringval(string,val,info) + do ilev_=2,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%iprcparm(what) = val + end do + case(mld_coarse_mat_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + call get_stringval(string,val,info) + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = val + case(mld_coarse_solve_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + call get_stringval(string,val,info) + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + endif + +contains + + ! + ! Subroutine: get_stringval + ! Note: internal subroutine of mld_dprecsetc + ! + ! This routine converts the string contained into string into the corresponding + ! integer value. + ! + ! Arguments: + ! string - character(len=*), input. + ! The string to be converted. + ! val - integer, output. + ! The integer value corresponding to the string + ! info - integer, output. + ! Error code. + ! + subroutine get_stringval(string,val,info) + + ! Arguments + character(len=*), intent(in) :: string + integer, intent(out) :: val, info + + info = 0 + select case(psb_toupper(trim(string))) + case('NONE') + val = 0 + case('HALO') + val = psb_halo_ + case('SUM') + val = psb_sum_ + case('AVG') + val = psb_avg_ + case('ILU') + val = mld_ilu_n_ + case('MILU') + val = mld_milu_n_ + case('ILUT') + val = mld_ilu_t_ + case('UMF') + val = mld_umf_ + case('SLU') + val = mld_slu_ + case('SLUDIST') + val = mld_sludist_ + case('ADD') + val = mld_add_ml_ + case('MULT') + val = mld_mult_ml_ + case('DEC') + val = mld_dec_aggr_ + case('SYMDEC') + val = mld_sym_dec_aggr_ + case('GLB') + val = mld_glb_aggr_ + case('REPL') + val = mld_repl_mat_ + case('DIST') + val = mld_distr_mat_ + case('RAW') + val = mld_no_smooth_ + case('SMOOTH') + val = mld_smooth_prol_ + case('PRE') + val = mld_pre_smooth_ + case('POST') + val = mld_post_smooth_ + case('TWOSIDE','BOTH') + val = mld_twoside_smooth_ + case('NOPREC') + val = mld_noprec_ + case('DIAG') + val = mld_diag_ + case('BJAC') + val = mld_bjac_ + case('AS') + val = mld_as_ + case default + val = -1 + info = -1 + end select + if (info /= 0) then + write(0,*) name,': Error: unknown request: "',trim(string),'"' + end if + end subroutine get_stringval +end subroutine mld_cprecsetc + + +! +! Subroutine: mld_cprecsetr +! Version: complex +! +! This routine sets the real parameters defining the preconditioner. More +! precisely, the real parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and character parameters, see mld_cprecseti and mld_cprecsetc, +! respectively. +! +! +! Arguments: +! p - type(mld_cprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in MLD2P4 user's guide. +! val - real(psb_spk_), input. +! The value of the parameter to be set. The list of allowed +! values is reported in MLD2P4 user's guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +subroutine mld_cprecsetr(p,what,val,info,ilev) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_cprecsetr + + implicit none + + ! Arguments + type(mld_cprec_type), intent(inout) :: p + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + +! Local variables + integer :: ilev_,nlev_ + character(len=*), parameter :: name='mld_precsetd' + + info = 0 + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if (.not.allocated(p%baseprecv)) then + write(0,*) name,': Error: Uninitialized preconditioner, should call MLD_PRECINIT' + info = 3111 + return + endif + nlev_ = size(p%baseprecv) + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + info = -1 + return + endif + if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = 3111 + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(what) + case(mld_fact_thrs_) + p%baseprecv(ilev_)%rprcparm(what) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + else if (ilev_ > 1) then + select case(what) + case(mld_aggr_damp_,mld_fact_thrs_) + p%baseprecv(ilev_)%rprcparm(what) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate levels + ! + + select case(what) + case(mld_fact_thrs_) + do ilev_=1,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%rprcparm(what) = val + end do + case(mld_aggr_damp_) + do ilev_=2,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%rprcparm(what) = val + end do + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + endif + +end subroutine mld_cprecsetr diff --git a/mlprec/mld_cslu_bld.f90 b/mlprec/mld_cslu_bld.f90 new file mode 100644 index 00000000..442df55b --- /dev/null +++ b/mlprec/mld_cslu_bld.f90 @@ -0,0 +1,129 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cslu_bld.f90 +! +! Subroutine: mld_cslu_bld +! Version: complex +! +! This routine computes the LU factorization of the local part of the matrix +! stored into a, by using SuperLU. +! +! The matrix to be factorized is +! - either a submatrix of the distributed matrix corresponding to any level +! of a multilevel preconditioner, and its factorization is used to build +! the 'base preconditioner' corresponding to that level, +! - or a copy of the whole matrix corresponding to the coarsest level of +! a multilevel preconditioner, and its factorization is used to build +! the 'base preconditioner' corresponding to the coarsest level. +! +! The data structure allocated by SuperLU to store the L and U factors is +! pointed by p%iprcparm(mld_slu_ptr_). +! +! +! Arguments: +! a - type(psb_zspmat_type), input/output. +! The sparse matrix structure containing the local submatrix to +! be factorized. +! desc_a - type(psb_desc_type), input. +! The communication descriptor associated to a. +! p - type(mld_cbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the pointer, +! p%iprcparm(mld_slu_ptr_), to the data structure used by SuperLU +! to store the L and U factors. +! info - integer, output. +! Error code. +! +subroutine mld_cslu_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cslu_bld + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: nzt,ictxt,me,np,err_act + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info=0 + name='mld_cslu_bld' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + if (psb_toupper(a%fida) /= 'CSR') then + info=135 + call psb_errpush(info,name,a_err=a%fida) + goto 9999 + endif + + nzt = psb_sp_get_nnzeros(a) + ! + ! Compute the LU factorization + ! + call mld_cslu_fact(a%m,nzt,& + & a%aspk,a%ia2,a%ia1,p%iprcparm(mld_slu_ptr_),info) + + if (info /= 0) then + ch_err='mld_slu_fact' + call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cslu_bld + diff --git a/mlprec/mld_cslu_interface.c b/mlprec/mld_cslu_interface.c new file mode 100644 index 00000000..f2913de7 --- /dev/null +++ b/mlprec/mld_cslu_interface.c @@ -0,0 +1,399 @@ +/* + * + * MLD2P4 version 1.0 + * MultiLevel Domain Decomposition Parallel Preconditioners Package + * based on PSBLAS (Parallel Sparse BLAS version 2.2) + * + * (C) Copyright 2008 + * + * Salvatore Filippone University of Rome Tor Vergata + * Alfredo Buttari University of Rome Tor Vergata + * Pasqua D'Ambra ICAR-CNR, Naples + * Daniela di Serafino Second University of Naples + * + * 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 MLD2P4 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 MLD2P4 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: mld_cslu_interface.c + * + * Functions: mld_cslu_fact_, mld_cslu_solve_, mld_cslu_free_. + * + * This file is an interface to the SuperLU routines for sparse factorization and + * solve. It was obtained by modifying the c_fortran_cgssv.c file from the SuperLU + * source distribution; original copyright terms are reproduced below. + * + */ + + +/* ===================== + +Copyright (c) 2003, The Regents of the University of California, through +Lawrence Berkeley National Laboratory (subject to receipt of any required +approvals from U.S. Dept. of Energy) + +All rights reserved. + +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) Neither the name of Lawrence Berkeley National Laboratory, U.S. Dept. of +Energy nor the names of its contributors may be used to endorse or promote +products derived from this software without specific prior 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 COPYRIGHT OWNER OR +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. + +*/ + +/* + * -- SuperLU routine (version 3.0) -- + * Univ. of California Berkeley, Xerox Palo Alto Research Center, + * and Lawrence Berkeley National Lab. + * October 15, 2003 + * + */ + +#ifdef Have_SLU_ +#include "slu_cdefs.h" +#define HANDLE_SIZE 8 +/* kind of integer to hold a pointer. Use int. + This might need to be changed on 64-bit systems. */ +#ifdef Ptr64Bits +typedef long long fptr; +#else +typedef int fptr; /* 32-bit by default */ +#endif + +typedef struct { + SuperMatrix *L; + SuperMatrix *U; + int *perm_c; + int *perm_r; +} factors_t; + + +#else + +#include + +#endif + + +#ifdef LowerUndescore +#define mld_cslu_fact_ mld_cslu_fact_ +#define mld_cslu_solve_ mld_cslu_solve_ +#define mld_cslu_free_ mld_cslu_free_ +#endif +#ifdef LowerDoubleUndescore +#define mld_cslu_fact_ mld_cslu_fact__ +#define mld_cslu_solve_ mld_cslu_solve__ +#define mld_cslu_free_ mld_cslu_free__ +#endif +#ifdef LowerCase +#define mld_cslu_fact_ mld_cslu_fact +#define mld_cslu_solve_ mld_cslu_solve +#define mld_cslu_free_ mld_cslu_free +#endif +#ifdef UpperUndescore +#define mld_cslu_fact_ MLD_CSLU_FACT_ +#define mld_cslu_solve_ MLD_CSLU_SOLVE_ +#define mld_cslu_free_ MLD_CSLU_FREE_ +#endif +#ifdef UpperDoubleUndescore +#define mld_cslu_fact_ MLD_CSLU_FACT__ +#define mld_cslu_solve_ MLD_CSLU_SOLVE__ +#define mld_cslu_free_ MLD_CSLU_FREE__ +#endif +#ifdef UpperCase +#define mld_cslu_fact_ MLD_CSLU_FACT +#define mld_cslu_solve_ MLD_CSLU_SOLVE +#define mld_cslu_free_ MLD_CSLU_FREE +#endif + + + + +void +mld_cslu_fact_(int *n, int *nnz, +#ifdef Have_SLU_ + complex *values, int *colind, int *rowptr, + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *values, int *colind, int *rowptr, + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * performs LU decomposition. + * + * f_factors (input/output) fptr* + * On output contains the pointer pointing to + * the structure of the factored matrices. + * + */ + +#ifdef Have_SLU_ + SuperMatrix A, AC, B; + SuperMatrix *L, *U; + int *perm_r; /* row permutations from partial pivoting */ + int *perm_c; /* column permutation vector */ + int *etree; /* column elimination tree */ + SCformat *Lstore; + NCformat *Ustore; + int i, panel_size, permc_spec, relax; + trans_t trans; + float drop_tol = 0.0; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + trans = NOTRANS; + + + /* Set the default input options. */ + set_default_options(&options); + + /* Initialize the statistics variables. */ + StatInit(&stat); + + /* Adjust to 0-based indexing */ + for (i = 0; i < *nnz; ++i) --colind[i]; + for (i = 0; i <= *n; ++i) --rowptr[i]; + + cCreate_CompRow_Matrix(&A, *n, *n, *nnz, values, colind, rowptr, + SLU_NR, SLU_C, SLU_GE); + L = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) ); + U = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) ); + if ( !(perm_r = intMalloc(*n)) ) ABORT("Malloc fails for perm_r[]."); + if ( !(perm_c = intMalloc(*n)) ) ABORT("Malloc fails for perm_c[]."); + if ( !(etree = intMalloc(*n)) ) ABORT("Malloc fails for etree[]."); + + /* + * Get column permutation vector perm_c[], according to permc_spec: + * permc_spec = 0: natural ordering + * permc_spec = 1: minimum degree on structure of A'*A + * permc_spec = 2: minimum degree on structure of A'+A + * permc_spec = 3: approximate minimum degree for unsymmetric matrices + */ + options.ColPerm=2; + permc_spec = options.ColPerm; + get_perm_c(permc_spec, &A, perm_c); + + sp_preorder(&options, &A, perm_c, etree, &AC); + + panel_size = sp_ienv(1); + relax = sp_ienv(2); + + cgstrf(&options, &AC, drop_tol, relax, panel_size, + etree, NULL, 0, perm_c, perm_r, L, U, &stat, info); + + if ( *info == 0 ) { + Lstore = (SCformat *) L->Store; + Ustore = (NCformat *) U->Store; + cQuerySpace(L, U, &mem_usage); +#if 0 + printf("No of nonzeros in factor L = %d\n", Lstore->nnz); + printf("No of nonzeros in factor U = %d\n", Ustore->nnz); + printf("No of nonzeros in L+U = %d\n", Lstore->nnz + Ustore->nnz); + printf("L\\U MB %.3f\ttotal MB needed %.3f\texpansions %d\n", + mem_usage.for_lu/1e6, mem_usage.total_needed/1e6, + mem_usage.expansions); +#endif + } else { + printf("cgstrf() error returns INFO= %d\n", *info); + if ( *info <= *n ) { /* factorization completes */ + cQuerySpace(L, U, &mem_usage); + printf("L\\U MB %.3f\ttotal MB needed %.3f\texpansions %d\n", + mem_usage.for_lu/1e6, mem_usage.total_needed/1e6, + mem_usage.expansions); + } + } + + /* Restore to 1-based indexing */ + for (i = 0; i < *nnz; ++i) ++colind[i]; + for (i = 0; i <= *n; ++i) ++rowptr[i]; + + /* Save the LU factors in the factors handle */ + LUfactors = (factors_t*) SUPERLU_MALLOC(sizeof(factors_t)); + LUfactors->L = L; + LUfactors->U = U; + LUfactors->perm_c = perm_c; + LUfactors->perm_r = perm_r; + *f_factors = (fptr) LUfactors; + + /* Free un-wanted storage */ + SUPERLU_FREE(etree); + Destroy_SuperMatrix_Store(&A); + Destroy_CompCol_Permuted(&AC); + StatFree(&stat); +#else + fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + +void +mld_cslu_solve_(int *itrans, int *n, int *nrhs, +#ifdef Have_SLU_ + complex *b, int *ldb, + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *b, int *ldb, + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * performs triangular solve + * + */ +#ifdef Have_SLU_ + SuperMatrix B; + SuperMatrix *L, *U; + int *perm_r; /* row permutations from partial pivoting */ + int *perm_c; /* column permutation vector */ + int *etree; /* column elimination tree */ + SCformat *Lstore; + NCformat *Ustore; + int i, panel_size, permc_spec, relax; + trans_t trans; + float drop_tol = 0.0; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + if (*itrans == 0) { + trans = NOTRANS; + } else if (*itrans ==1) { + trans = TRANS; + } else if (*itrans ==2) { + trans = CONJ; + } else { + trans = NOTRANS; + } + /* Initialize the statistics variables. */ + StatInit(&stat); + + /* Extract the LU factors in the factors handle */ + LUfactors = (factors_t*) *f_factors; + L = LUfactors->L; + U = LUfactors->U; + perm_c = LUfactors->perm_c; + perm_r = LUfactors->perm_r; + + cCreate_Dense_Matrix(&B, *n, *nrhs, b, *ldb, SLU_DN, SLU_C, SLU_GE); + /* Solve the system A*X=B, overwriting B with X. */ + cgstrs (trans, L, U, perm_c, perm_r, &B, &stat, info); + if (info != 0) { + if (B.Stype != SLU_DN) fprintf(stderr,"cgstrs error kind 1: SLU_DN\n"); + if (B.Dtype != SLU_C) fprintf(stderr,"cgstrs error kind 2: SLU_C\n"); + if (B.Mtype != SLU_GE) fprintf(stderr,"cgstrs error kind 3: SLU_GE\n"); + } + + Destroy_SuperMatrix_Store(&B); + StatFree(&stat); +#else + fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif + +} + + +void +mld_cslu_free_( +#ifdef Have_SLU_ + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * + * free all storage in the end + * + */ +#ifdef Have_SLU_ + SuperMatrix A, AC, B; + SuperMatrix *L, *U; + int *perm_r; /* row permutations from partial pivoting */ + int *perm_c; /* column permutation vector */ + int *etree; /* column elimination tree */ + SCformat *Lstore; + NCformat *Ustore; + int i, panel_size, permc_spec, relax; + trans_t trans; + float drop_tol = 0.0; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + trans = NOTRANS; + /* Free the LU factors in the factors handle */ + LUfactors = (factors_t*) *f_factors; + SUPERLU_FREE (LUfactors->perm_r); + SUPERLU_FREE (LUfactors->perm_c); + Destroy_SuperNode_Matrix(LUfactors->L); + Destroy_CompCol_Matrix(LUfactors->U); + SUPERLU_FREE (LUfactors->L); + SUPERLU_FREE (LUfactors->U); + SUPERLU_FREE (LUfactors); + *info = 0; +#else + fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + diff --git a/mlprec/mld_cslud_bld.f90 b/mlprec/mld_cslud_bld.f90 new file mode 100644 index 00000000..644c16fb --- /dev/null +++ b/mlprec/mld_cslud_bld.f90 @@ -0,0 +1,149 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cslud_bld.f90 +! +! Subroutine: mld_csludist_bld +! Version: real +! +! This routine computes the LU factorization of of a distributed matrix, +! by using SuperLU_DIST. +! +! The matrix to be factorized is the coarsest level matrix of a multilevel +! preconditioner and is distributed among the processes. Its factorization +! is used to build the 'base preconditioner' corresponding to the coarsest +! level. +! +! The data structure allocated by SuperLU_DIST to store the L and U factors +! is pointed by p%iprcparm(mld_slud_ptr_). +! +! +! Arguments: +! a - type(psb_cspmat_type), input/output. +! The sparse matrix structure containing the local part of the +! matrix to be factorized. +! desc_a - type(psb_desc_type), input. +! The communication descriptor associated to a. +! p - type(mld_cbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the pointer, +! p%iprcparm(mld_slud_ptr_), to the data structure used by +! SuperLU_DIST to store the L and U factors. +! info - integer, output. +! Error code. +! +subroutine mld_csludist_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_csludist_bld + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: nzt,ictxt,me,np,err_act,& + & mglob,ifrst,ibcheck,nrow,ncol,npr,npc + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info=0 + name='mld_cslud_bld' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + if (psb_toupper(a%fida) /= 'CSR') then + info=135 + call psb_errpush(info,name,a_err=a%fida) + goto 9999 + endif + + ! + ! WARN: we need to check for a BLOCK distribution (this is the + ! distribution required by SuperLU_DIST) + ! + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + ifrst = desc_a%loc_to_glob(1) + ibcheck = desc_a%loc_to_glob(nrow) - ifrst + 1 + ibcheck = ibcheck - nrow + call psb_amx(ictxt,ibcheck) + if (ibcheck > 0) then + write(0,*) 'Warning: does not look like a BLOCK distribution' + endif + + mglob = psb_cd_get_global_rows(desc_a) + nzt = psb_sp_get_nnzeros(a) + + npr = np + npc = 1 + call psb_loc_to_glob(a%ia1(1:nzt),desc_a,info,iact='I') + + ! + ! Compute the LU factorization + ! + call mld_csludist_fact(mglob,nrow,nzt,ifrst,& + & a%aspk,a%ia2,a%ia1,p%iprcparm(mld_slud_ptr_),& + & npr, npc, info) + if (info /= 0) then + ch_err='psb_sludist_fact' + call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + call psb_glob_to_loc(a%ia1(1:nzt),desc_a,info,iact='I') + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_csludist_bld + diff --git a/mlprec/mld_cslud_interface.c b/mlprec/mld_cslud_interface.c new file mode 100644 index 00000000..02572795 --- /dev/null +++ b/mlprec/mld_cslud_interface.c @@ -0,0 +1,402 @@ +/* + * + * MLD2P4 version 1.0 + * MultiLevel Domain Decomposition Parallel Preconditioners Package + * based on PSBLAS (Parallel Sparse BLAS version 2.2) + * + * (C) Copyright 2008 + * + * Salvatore Filippone University of Rome Tor Vergata + * Alfredo Buttari University of Rome Tor Vergata + * Pasqua D'Ambra ICAR-CNR, Naples + * Daniela di Serafino Second University of Naples + * + * 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 MLD2P4 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 MLD2P4 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: mld_zslud_interface.c + * + * Functions: mld_zsludist_fact_, mld_zsludist_solve_, mld_zsludist_free_. + * + * This file is an interface to the SuperLU_dist routines for sparse factorization and + * solve. It was obtained by modifying the c_fortran_zgssv.c file from the SuperLU_dist + * source distribution; original copyright terms are reproduced below. + * + */ + +/* ===================== + +Copyright (c) 2003, The Regents of the University of California, through +Lawrence Berkeley National Laboratory (subject to receipt of any required +approvals from U.S. Dept. of Energy) + +All rights reserved. + +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) Neither the name of Lawrence Berkeley National Laboratory, U.S. Dept. of +Energy nor the names of its contributors may be used to endorse or promote +products derived from this software without specific prior 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 COPYRIGHT OWNER OR +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. + +*/ + +/* + * -- Distributed SuperLU routine (version 2.0) -- + * Lawrence Berkeley National Lab, Univ. of California Berkeley. + * March 15, 2003 + * + */ + +/* No single complex version in SuperLU_Dist */ + +#ifdef Have_SLUDist_ +#undef Have_SLUDist_ +#endif +#ifdef Have_SLUDist_ +#include +#include "superlu_zdefs.h" + +#define HANDLE_SIZE 8 +/* kind of integer to hold a pointer. Use int. + This might need to be changed on 64-bit systems. */ +#ifdef LargeFptr +typedef long long fptr; +#else +typedef int fptr; /* 32-bit by default */ +#endif + +typedef struct { + SuperMatrix *A; + LUstruct_t *LUstruct; + gridinfo_t *grid; + ScalePermstruct_t *ScalePermstruct; +} factors_t; + + +#else + +#include + +#endif + + +#ifdef LowerUnderscore +#define mld_csludist_fact_ mld_csludist_fact_ +#define mld_csludist_solve_ mld_csludist_solve_ +#define mld_csludist_free_ mld_csludist_free_ +#endif +#ifdef LowerDoubleUnderscore +#define mld_csludist_fact_ mld_csludist_fact__ +#define mld_csludist_solve_ mld_csludist_solve__ +#define mld_csludist_free_ mld_csludist_free__ +#endif +#ifdef LowerCase +#define mld_csludist_fact_ mld_csludist_fact +#define mld_csludist_solve_ mld_csludist_solve +#define mld_csludist_free_ mld_csludist_free +#endif +#ifdef UpperUnderscore +#define mld_csludist_fact_ MLD_CSLUDIST_FACT_ +#define mld_csludist_solve_ MLD_CSLUDIST_SOLVE_ +#define mld_csludist_free_ MLD_CSLUDIST_FREE_ +#endif +#ifdef UpperDoubleUnderscore +#define mld_csludist_fact_ MLD_CSLUDIST_FACT__ +#define mld_csludist_solve_ MLD_CSLUDIST_SOLVE__ +#define mld_csludist_free_ MLD_CSLUDIST_FREE__ +#endif +#ifdef UpperCase +#define mld_csludist_fact_ MLD_CSLUDIST_FACT +#define mld_csludist_solve_ MLD_CSLUDIST_SOLVE +#define mld_csludist_free_ MLD_CSLUDIST_FREE +#endif + + + + +void +mld_csludist_fact_(int *n, int *nl, int *nnzl, int *ffstr, +#ifdef Have_SLUDist_ + complex *values, int *rowptr, int *colind, + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *values, int *rowptr, int *colind, + void *f_factors, +#endif + int *nprow, int *npcol, int *info) + +{ +/* + * This routine can be called from Fortran. + * performs LU decomposition. + * + * f_factors (input/output) fptr* + * On output contains the pointer pointing to + * the structure of the factored matrices. + * + */ + +#ifdef Have_SLUDist_ + SuperMatrix *A; + NRformat_loc *Astore; + + ScalePermstruct_t *ScalePermstruct; + LUstruct_t *LUstruct; + SOLVEstruct_t SOLVEstruct; + gridinfo_t *grid; + int i, panel_size, permc_spec, relax; + trans_t trans; + float drop_tol = 0.0,berr[1]; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + int fst_row; + int *icol,*irpt; + complex *ival,b[1]; + + trans = NOTRANS; + grid = (gridinfo_t *) SUPERLU_MALLOC(sizeof(gridinfo_t)); + superlu_gridinit(MPI_COMM_WORLD, *nprow, *npcol, grid); + /* Initialize the statistics variables. */ + PStatInit(&stat); + fst_row = (*ffstr) -1; + /* Adjust to 0-based indexing */ + icol = (int *) malloc((*nnzl)*sizeof(int)); + irpt = (int *) malloc(((*nl)+1)*sizeof(int)); + ival = (complex *) malloc((*nnzl)*sizeof(doublecomplex)); + for (i = 0; i < *nnzl; ++i) ival[i] = values[i]; + for (i = 0; i < *nnzl; ++i) icol[i] = colind[i] -1; + for (i = 0; i <= *nl; ++i) irpt[i] = rowptr[i] -1; + + A = (SuperMatrix *) malloc(sizeof(SuperMatrix)); + zCreate_CompRowLoc_Matrix_dist(A, *n, *n, *nnzl, *nl, fst_row, + ival, icol, irpt, + SLU_NR_loc, SLU_Z, SLU_GE); + + /* Initialize ScalePermstruct and LUstruct. */ + ScalePermstruct = (ScalePermstruct_t *) SUPERLU_MALLOC(sizeof(ScalePermstruct_t)); + LUstruct = (LUstruct_t *) SUPERLU_MALLOC(sizeof(LUstruct_t)); + ScalePermstructInit(*n,*n, ScalePermstruct); + LUstructInit(*n,*n, LUstruct); + + /* Set the default input options. */ + set_default_options_dist(&options); + options.IterRefine=NO; + options.PrintStat=NO; + + pzgssvx(&options, A, ScalePermstruct, b, *nl, 0, + grid, LUstruct, &SOLVEstruct, berr, &stat, info); + + if ( *info == 0 ) { + ; + } else { + printf("pzgssvx() error returns INFO= %d\n", *info); + if ( *info <= *n ) { /* factorization completes */ + ; + } + } + if (options.SolveInitialized) { + zSolveFinalize(&options,&SOLVEstruct); + } + + + /* Save the LU factors in the factors handle */ + LUfactors = (factors_t *) SUPERLU_MALLOC(sizeof(factors_t)); + LUfactors->LUstruct = LUstruct; + LUfactors->grid = grid; + LUfactors->A = A; + LUfactors->ScalePermstruct = ScalePermstruct; +/* fprintf(stderr,"slud factor: LUFactors %p \n",LUfactors); */ +/* fprintf(stderr,"slud factor: A %p %p\n",A,LUfactors->A); */ +/* fprintf(stderr,"slud factor: grid %p %p\n",grid,LUfactors->grid); */ +/* fprintf(stderr,"slud factor: LUstruct %p %p\n",LUstruct,LUfactors->LUstruct); */ + *f_factors = (fptr) LUfactors; + + PStatFree(&stat); +#else + fprintf(stderr," SLUDist Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + +void +mld_csludist_solve_(int *itrans, int *n, int *nrhs, +#ifdef Have_SLUDist_ + doublecomplex *b, int *ldb, + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *b, int *ldb, + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * performs triangular solve + * + */ +#ifdef Have_SLUDist_ + SuperMatrix *A; + ScalePermstruct_t *ScalePermstruct; + LUstruct_t *LUstruct; + SOLVEstruct_t SOLVEstruct; + gridinfo_t *grid; + int i, panel_size, permc_spec, relax; + trans_t trans; + double drop_tol = 0.0; + double *berr; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + LUfactors = (factors_t *) *f_factors ; + A = LUfactors->A ; + LUstruct = LUfactors->LUstruct ; + grid = LUfactors->grid ; + + ScalePermstruct = LUfactors->ScalePermstruct; +/* fprintf(stderr,"slud solve: LUFactors %p \n",LUfactors); */ +/* fprintf(stderr,"slud solve: A %p %p\n",A,LUfactors->A); */ +/* fprintf(stderr,"slud solve: grid %p %p\n",grid,LUfactors->grid); */ +/* fprintf(stderr,"slud solve: LUstruct %p %p\n",LUstruct,LUfactors->LUstruct); */ + + + if (*itrans == 0) { + trans = NOTRANS; + } else if (*itrans ==1) { + trans = TRANS; + } else if (*itrans ==2) { + trans = CONJ; + } else { + trans = NOTRANS; + } + +/* fprintf(stderr,"Entry to sludist_solve\n"); */ + berr = (double *) malloc((*nrhs) *sizeof(double)); + + /* Initialize the statistics variables. */ + PStatInit(&stat); + + /* Set the default input options. */ + set_default_options_dist(&options); + options.IterRefine = NO; + options.Fact = FACTORED; + options.PrintStat = NO; + + pzgssvx(&options, A, ScalePermstruct, b, *ldb, *nrhs, + grid, LUstruct, &SOLVEstruct, berr, &stat, info); + +/* fprintf(stderr,"Double check: after solve %d %lf\n",*info,berr[0]); */ + if (options.SolveInitialized) { + zSolveFinalize(&options,&SOLVEstruct); + } + PStatFree(&stat); + free(berr); +#else + fprintf(stderr," SLUDist Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif + +} + + +void +mld_csludist_free_( +#ifdef Have_SLUDist_ + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * + * free all storage in the end + * + */ +#ifdef Have_SLUDist_ + SuperMatrix *A; + ScalePermstruct_t *ScalePermstruct; + LUstruct_t *LUstruct; + SOLVEstruct_t SOLVEstruct; + gridinfo_t *grid; + int i, panel_size, permc_spec, relax; + trans_t trans; + double drop_tol = 0.0; + double *berr; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + LUfactors = (factors_t *) *f_factors ; + A = LUfactors->A ; + LUstruct = LUfactors->LUstruct ; + grid = LUfactors->grid ; + ScalePermstruct = LUfactors->ScalePermstruct; + + Destroy_CompRowLoc_Matrix_dist(A); + ScalePermstructFree(ScalePermstruct); + LUstructFree(LUstruct); + superlu_gridexit(grid); + + free(grid); + free(LUstruct); + free(LUfactors); + +#else + fprintf(stderr," SLUDist Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + diff --git a/mlprec/mld_csp_renum.f90 b/mlprec/mld_csp_renum.f90 new file mode 100644 index 00000000..c2d98959 --- /dev/null +++ b/mlprec/mld_csp_renum.f90 @@ -0,0 +1,368 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_csp_renum.f90 +! +! Subroutine: mld_csp_renum +! Version: complex +! Contains: gps_reduction +! +! This routine reorders the rows and the columns of the local part of a sparse +! distributed matrix, according to one of the following criteria: +! 1. the numbering of the global column indices, +! 2. the Gibbs-Poole-Stockmeyer (GPS) band reduction algorithm. +! NOTE: the GPS algorithm is disabled for the time being (see mld_prec_type.f90). +! +! The matrix to be reordered is stored into a and blck, as specified in the +! description of the arguments below. +! +! If required by the user (p%iprcparm(mld_sub_ren_) /= 0), the routine is +! used by mld_fact_bld in building the block-Jacobi and Additive Schwarz +! 'base preconditioners' corresponding to any level of a multilevel +! preconditioner. +! +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the 'original' local +! part of the matrix to be reordered, i.e. the rows of the matrix +! held by the calling process according to the initial data +! distribution. +! blck - type(psb_cspmat_type), input. +! The sparse matrix structure containing the remote rows of the +! matrix to be reordered, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0.If the overlap is 0, then blck does not contain +! any row. +! p - type(mld_cbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. In input it +! contains information on the type of reordering to be applied +! and on the matrix to be reordered. In output it contains +! information on the reordering applied. +! atmp - type(psb_cspmat_type), output. +! The sparse matrix structure containing the whole local reordered +! matrix. +! info - integer, output. +! Error code. +! +subroutine mld_csp_renum(a,blck,p,atmp,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_csp_renum + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in) :: a,blck + type(psb_cspmat_type), intent(out) :: atmp + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + character(len=20) :: name, ch_err + integer :: nztota, nztotb, nztmp, nnr, i,k + integer, allocatable :: itmp(:), itmp2(:) + integer :: ictxt,np,me, err_act + real(psb_dpk_) :: t3,t4 + + if (psb_get_errstatus().ne.0) return + info=0 + name='mld_csp_renum' + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(p%desc_data) + call psb_info(ictxt, me, np) + + ! + ! NOTE: the matrix to be reordered is converted into the COO format. + ! If necessary it is converted from the COO to the CSR format. + ! The output matrix is in COO format. + ! + + ! + ! Convert a into the COO format and extend it up to a%m+blck%m rows + ! by adding null rows. The converted extended matrix is stored in atmp. + ! + nztota=psb_sp_get_nnzeros(a) + nztotb=psb_sp_get_nnzeros(blck) + call psb_spcnv(a,atmp,info,afmt='coo',dupl=psb_dupl_add_) + call psb_rwextd(a%m+blck%m,atmp,info,blck) + + if (p%iprcparm(mld_sub_ren_)==mld_renum_glb_) then + + ! + ! Remember: we have switched IA1=COLS and IA2=ROWS. + ! Now identify the set of distinct local column indices. + ! + nnr = p%desc_data%matrix_data(psb_n_row_) + allocate(p%perm(nnr),p%invperm(nnr),itmp2(nnr),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + do i=1, nnr + itmp2(i) = i + end do + call psb_loc_to_glob(itmp2(1:nnr),p%desc_data,info,iact='I') + ! + ! Compute reordering. We want new(i) = old(perm(i)). + ! + call psb_msort(itmp2(1:nnr),ix=p%perm) + ! + ! Compute the inverse of the permutation stored in perm + ! + do k=1, nnr + p%invperm(p%perm(k)) = k + enddo + t3 = psb_wtime() + + else if (p%iprcparm(mld_sub_ren_)==mld_renum_gps_) then + + ! + ! This is a renumbering with Gibbs-Poole-Stockmeyer + ! band reduction. Switched off for now. To be fixed, + ! gps_reduction should get p%perm. + ! + + ! + ! Convert atmp into the CSR format + ! + call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) + nztmp = psb_sp_get_nnzeros(atmp) + + ! + ! Realloc the permutation arrays + ! + call psb_realloc(atmp%m,p%perm,info) + if(info/=0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_realloc(atmp%m,p%invperm,info) + if(info/=0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(itmp(max(8,atmp%m+2,nztmp+2)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + itmp(1:8) = 0 + + ! + ! Renumber rows and columns according to the GPS algorithm + ! + call gps_reduction(atmp%m,atmp%ia2,atmp%ia1,p%perm,p%invperm,info) + if(info/=0) then + info=4010 + ch_err='gps_reduction' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Compute the inverse permutation + ! + do k=1, atmp%m + p%invperm(p%perm(k)) = k + enddo + t3 = psb_wtime() + + call psb_spcnv(atmp,info,afmt='coo',dupl=psb_dupl_add_) + + end if + + ! + ! Rebuild atmp with the new numbering (COO format) + ! + nztmp=psb_sp_get_nnzeros(atmp) + do i=1,nztmp + atmp%ia1(i) = p%perm(a%ia1(i)) + atmp%ia2(i) = p%invperm(a%ia2(i)) + end do + call psb_spcnv(atmp,info,afmt='coo',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_fixcoo') + goto 9999 + end if + + t4 = psb_wtime() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + ! + ! Subroutine: gps_reduction + ! Note: internal subroutine of mld_csp_renum + ! + ! Compute a renumbering of the row and column indices of a sparse matrix + ! according to the Gibbs-Poole-Stockmeyer band reduction algorithm. The + ! matrix is stored in CSR format. + ! + ! This routine has been obtained by adapting ACM TOMS Algorithm 582. + ! + ! + ! Arguments: + ! m - integer, ... + ! The number of rows of the matrix to which the renumbering + ! is applied. + ! ia - integer, dimension(:), ... + ! The indices identifying the first nonzero entry of each row + ! of the matrix, according to the CSR storage format. + ! ja - integer, dimension(:), ... + ! The column indices of the nonzero entries of the matrix, + ! according to the CSR storage format. + ! perm - integer, dimension(:), ... + ! The row/column index permutation corresponding to the + ! renumbering. + ! iperm - integer, dimension(:),... + ! The inverse of the row/column permutation stored in perm. + ! info - integer, output. + ! Error code + ! + subroutine gps_reduction(m,ia,ja,perm,iperm,info) + + ! Arguments + integer :: m + integer,dimension(:) :: ia,ja,perm,iperm + integer, intent(out) :: info + + ! Local variables + integer :: i,j,dgConn,Npnt + integer :: n,idpth,ideg,ibw2,ipf2 + integer,dimension(:,:),allocatable::NDstk + integer,dimension(:),allocatable::iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=0 + name='gps_reduction' + call psb_erractionsave(err_act) + + ! Compute the maximum connectivity degree + npnt = m + dgConn=0 + do i=1,m + dgconn = max(dgconn,(ia(i+1)-ia(i))) + enddo + ! The maximum connectivity value is dgConn + + n=Npnt ! Max number of rows + iDeg=dgConn ! Max connectivity + ! iDpth= ! Number of level (initialization not needed) + + allocate(NDstk(Npnt,dgConn),stat=info) + if (info/=0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + endif + allocate(iOld(Npnt),renum(Npnt+1),ndeg(Npnt),lvl(Npnt),lvls1(Npnt),& + &lvls2(Npnt),ccstor(Npnt),stat=info) + if (info/=0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + endif + + ! Prepare the matrix graph + Ndstk(:,:)=0 + do i=1,Npnt + k=0 + do j = ia(i),ia(i+1) - 1 + if ((1<=ja(j)).and.( ja( j ) /= i ).and.(ja(j)<=npnt)) then + k = k+1 + Ndstk(i,k)=ja(j) + endif + enddo + ndeg(i)=k + enddo + + ! Numbering + do i=1,Npnt + iOld(i)=i + enddo + + ! Call gps_reduce + call psb_gps_reduce(Ndstk,Npnt,iOld,renum,ndeg,lvl,lvls1, lvls2,ccstor,& + & ibw2,ipf2,n,idpth,ideg) + + ! Build permutation vector + perm(1:Npnt)=renum(1:Npnt) + + !Build inverse permutation vector + do i=1,Npnt + iperm(perm(i))=i + enddo + + ! Deallocate memory + deallocate(NDstk,iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine gps_reduction + +end subroutine mld_csp_renum diff --git a/mlprec/mld_csub_aply.f90 b/mlprec/mld_csub_aply.f90 new file mode 100644 index 00000000..9fea45e0 --- /dev/null +++ b/mlprec/mld_csub_aply.f90 @@ -0,0 +1,296 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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 mld_csub_aply.f90 +! +! Subroutine: mld_csub_aply +! Version: complex +! +! This routine computes +! +! Y = beta*Y + alpha*op(K^(-1))*X, +! +! where +! - K is a suitable matrix, as specified below, +! - op(K^(-1)) is K^(-1) or its transpose, according to the value of the +! argument trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! Depending on K, alpha and beta (and on the communication descriptor desc_data +! - see the arguments below), the above computation may correspond to one of +! the following tasks: +! +! 1. Application of a block-Jacobi preconditioner associated to a matrix A +! distributed among the processes. Here K is the preconditioner, op(K^(-1)) +! = K^(-1), alpha = 1 and beta = 0. +! +! 2. Application of block-Jacobi sweeps to compute an approximate solution of +! a linear system +! A*Y = X, +! +! distributed among the processes (note that a single block-Jacobi sweep, +! with null starting guess, corresponds to the application of a block-Jacobi +! preconditioner). Here K^(-1) denotes the iteration matrix of the +! block-Jacobi solver, op(K^(-1)) = K^(-1), alpha = 1 and beta = 0. +! +! 3. Solution, through the LU factorization, of a linear system +! +! A*Y = X, +! +! distributed among the processes. Here K = L*U = A, op(K^(-1)) = K^(-1), +! alpha = 1 and beta = 0. +! +! 4. (Approximate) solution, through the LU or incomplete LU factorization, of +! a linear system +! A*Y = X, +! +! replicated on the processes. Here K = L*U = A or K = L*U ~ A, op(K^(-1)) = +! K^(-1), alpha = 1 and beta = 0. +! +! The block-Jacobi preconditioner or solver and the L and U factors of the LU +! or ILU factorizations have been built by the routine mld_fact_bld and stored +! into the 'base preconditioner' data structure prec. See mld_fact_bld for more +! details. +! +! This routine is used by mld_as_aply, to apply a 'base' block-Jacobi or +! Additive Schwarz (AS) preconditioner at any level of a multilevel preconditioner, +! or a block-Jacobi or LU or ILU solver at the coarsest level of a multilevel +! preconditioner. +! +! Tasks 1, 3 and 4 may be selected when prec%iprcparm(smooth_sweeps_) = 1, +! while task 2 is selected when prec%iprcparm(smooth_sweeps_) > 1. Furthermore +! Tasks 1, 2 and 3 may be performed when the matrix A is +! distributed among the processes (prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_), +! while task 4 may be performed when A is replicated on the processes +! (prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_). Note that the matrix A is +! distributed among the processes at each level of the multilevel preconditioner, +! except the coarsest one, where it may be either distributed or replicated on +! the processes. Tasks 2, 3 and 4 are performed only at the coarsest level. +! Note also that this routine manages implicitly the fact that +! the matrix is distributed or replicated, i.e. it does not make any explicit +! reference to the value of prec%iprcparm(mld_coarse_mat_). +! +! Arguments: +! +! alpha - complex(psb_spk_), input. +! The scalar alpha. +! prec - type(mld_cbaseprec_type), input. +! The 'base preconditioner' data structure containing the local +! part of the preconditioner or solver. +! x - complex(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - complex(psb_spk_), input. +! The scalar beta. +! y - complex(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned or 'inverted'. +! trans - character(len=1), input. +! If trans='N','n' then op(K^(-1)) = K^(-1); +! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). +! if trans='C','c' then op(K^(-1)) = K^(-C) (transpose conjugate of K^(-1)). +! If prec%iprcparm(smooth_sweeps_) > 1, the value of trans provided +! in input is ignored. +! work - complex(psb_spk_), dimension (:), target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +subroutine mld_csub_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_csub_aply + + implicit none + + ! Arguments + type(psb_desc_type), intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: 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, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act + character(len=20) :: name + character :: trans_ + + name='mld_csub_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + + if (prec%iprcparm(mld_smooth_sweeps_) == 1) then + + call mld_sub_solve(alpha,prec,x,beta,y,desc_data,trans_,aux,info) + + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else if (prec%iprcparm(mld_smooth_sweeps_) > 1) then + ! + ! + ! Apply prec%iprcparm(smooth_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + + if (size(prec%av) < mld_ap_nd_) then + info = 4011 + goto 9999 + endif + + allocate(tx(n_col),ty(n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*n_col,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + tx = czero + ty = czero + do i=1, prec%iprcparm(mld_smooth_sweeps_) + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + ty(1:n_row) = x(1:n_row) + call psb_spmm(-cone,prec%av(mld_ap_nd_),tx,cone,ty,& + & prec%desc_data,info,work=aux,trans=trans_) + + if (info /=0) exit + + call mld_sub_solve(cone,prec,ty,czero,tx,desc_data,trans_,aux,info) + + if (info /=0) exit + end do + + if (info == 0) call psb_geaxpby(alpha,tx,beta,y,desc_data,info) + + if (info /= 0) then + info=4001 + call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + deallocate(tx,ty,stat=info) + if (info /= 0) then + info=4001 + call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1') + goto 9999 + end if + + else + + info = 10 + call psb_errpush(info,name,& + & i_err=(/2,prec%iprcparm(mld_smooth_sweeps_),0,0,0/)) + goto 9999 + + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_csub_aply + diff --git a/mlprec/mld_csub_solve.f90 b/mlprec/mld_csub_solve.f90 new file mode 100644 index 00000000..3da098be --- /dev/null +++ b/mlprec/mld_csub_solve.f90 @@ -0,0 +1,325 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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 mld_csub_solve.f90 +! +! Subroutine: mld_csub_solve +! Version: complex +! +! This routine computes +! +! Y = beta*Y + alpha*op(K^(-1))*X, +! +! where +! - K is a factored matrix, as specified below, +! - op(K^(-1)) is K^(-1) or its transpose, according to the value of the +! argument trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! Depending on K, alpha and beta (and on the communication descriptor desc_data +! - see the arguments below), the above computation may correspond to one of +! the following tasks: +! +! 1. approximate solution of a linear system +! +! A*Y = X, +! +! by using the L and U factors computed with an ILU (incomplete LU) factorization +! of A. In this case K = L*U ~ A, alpha = 1 and beta = 0. The factors L and U +! (and the matrix A) are either distributed and block-diagonal or replicated. +! +! 2. Solution of a linear system +! +! A*Y = X, +! +! by using the L and U factors computed with a LU factorization of A. In this +! case K = L*U = A, alpha = 1 and beta = 0. The LU factorization is performed +! by one of the following auxiliary pakages: +! a. UMFPACK, +! b. SuperLU, +! c. SuperLU_Dist. +! In the cases a. and b., the factors L and U (and the matrix A) are either +! distributed and block diagonal) or replicated; in the case c., L, U (and A) +! are distributed. +! +! This routine is used by mld_dsub_aply, to apply a 'base' block-Jacobi or +! Additive Schwarz (AS) preconditioner at any level of a multilevel preconditioner, +! or a block-Jacobi or LU or ILU solver at the coarsest level of a multilevel +! preconditioner. +! +! +! Arguments: +! +! alpha - complex(psb_spk_), input. +! The scalar alpha. +! prec - type(mld_cbaseprec_type), input. +! The 'base preconditioner' data structure containing the local +! part of the L and U factors of the matrix A. +! x - complex(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - complex(psb_spk_), input. +! The scalar beta. +! y - complex(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned or 'inverted'. +! trans - character(len=1), input. +! If trans='N','n' then op(K^(-1)) = K^(-1); +! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). +! if trans='C','c' then op(K^(-1)) = K^(-C) (transpose conjugate of K^(-1)). +! If prec%iprcparm(smooth_sweeps_) > 1, the value of trans provided +! in input is ignored. +! work - complex(psb_spk_), dimension (:), target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +subroutine mld_csub_solve(alpha,prec,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_csub_solve + + implicit none + + ! Arguments + type(psb_desc_type), intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: 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, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act + character(len=20) :: name + character :: trans_ + + interface + subroutine mld_cumf_solve(flag,m,x,b,n,ptr,info) + use psb_base_mod + integer, intent(in) :: flag,m,n,ptr + integer, intent(out) :: info + complex(psb_spk_), intent(in) :: b(*) + complex(psb_spk_), intent(inout) :: x(*) + end subroutine mld_cumf_solve + end interface + + name='mld_csub_solve' + info = 0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + + + select case(prec%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + ! + ! Apply a block-Jacobi preconditioner with ILU(k)/MILU(k)/ILU(k,t) + ! factorization of the blocks (distributed matrix) or approximately + ! solve a system through ILU(k)/MILU(k)/ILU(k,t) (replicated matrix). + ! + + select case(trans_) + case('N') + + call psb_spsm(cone,prec%av(mld_l_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=prec%d,choice=psb_none_,work=aux) + if (info == 0) call psb_spsm(alpha,prec%av(mld_u_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(cone,prec%av(mld_u_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=prec%d,choice=psb_none_, work=aux) + if(info ==0) call psb_spsm(alpha,prec%av(mld_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_,work=aux) + + case('C') + call psb_spsm(cone,prec%av(mld_u_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=conjg(prec%d),choice=psb_none_, work=aux) + if(info ==0) call psb_spsm(alpha,prec%av(mld_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_,work=aux) + case default + call psb_errpush(4001,name,a_err='Invalid TRANS in ILU subsolve') + goto 9999 + end select + + case(mld_slu_) + ! + ! Apply a block-Jacobi preconditioner with LU factorization of the + ! blocks (distributed matrix) or approximately solve a local linear + ! system through LU (replicated matrix). The SuperLU package is used + ! to apply the LU factorization in both cases. + ! + + ww(1:n_row) = x(1:n_row) + + select case(trans_) + case('N') + call mld_cslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) + case('T') + call mld_cslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) + case('C') + call mld_cslu_solve(2,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) + case default + call psb_errpush(4001,name,a_err='Invalid TRANS in SLU subsolve') + goto 9999 + end select + + if (info ==0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + case(mld_sludist_) + ! + ! Solve a distributed linear system with the LU factorization. + ! The SuperLU_DIST package is used. + ! + + ww(1:n_row) = x(1:n_row) + + select case(trans_) + case('N') + call mld_csludist_solve(0,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) + case('T') + call mld_csludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) + case('C') + call mld_csludist_solve(2,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) + case default + call psb_errpush(4001,name,a_err='Invalid TRANS in SLUDist subsolve') + goto 9999 + end select + + if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + case (mld_umf_) + ! + ! Apply a block-Jacobi preconditioner with LU factorization of the + ! blocks (distributed matrix) or approximately solve a local linear + ! system through LU (replicated matrix). The UMFPACK package is used + ! to apply the LU factorization in both cases. + ! + + select case(trans_) + case('N') + call mld_cumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) + case('T') + call mld_cumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) + case('C') + call mld_cumf_solve(2,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) + case default + call psb_errpush(4001,name,a_err='Invalid TRANS in UMF subsolve') + goto 9999 + end select + + if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + case default + call psb_errpush(4001,name,a_err='Invalid mld_sub_solve_') + goto 9999 + + end select + + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error in subsolve ') + goto 9999 + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_csub_solve + diff --git a/mlprec/mld_cumf_bld.f90 b/mlprec/mld_cumf_bld.f90 new file mode 100644 index 00000000..8872ec83 --- /dev/null +++ b/mlprec/mld_cumf_bld.f90 @@ -0,0 +1,138 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_cumf_bld.f90 +! +! Subroutine: mld_cumf_bld +! Version: complex +! +! This routine computes the LU factorization of the local part of the matrix +! stored into a, by using UMFPACK. +! +! The matrix to be factorized is +! - either a submatrix of the distributed matrix corresponding to any level +! of a multilevel preconditioner, and its factorization is used to build +! the 'base preconditioner' corresponding to that level, +! - or a copy of the whole matrix corresponding to the coarsest level of +! a multilevel preconditioner, and its factorization is used to build +! the 'base preconditioner' corresponding to the coarsest level. +! +! The data structures allocated by UMFPACK to compute the symbolic and the +! numeric factorization are pointed by p%iprcparm(mld_umf_symptr_) and +! p%iprcparm(mld_umf_numptr_). +! +! +! Arguments: +! a - type(psb_zspmat_type), input/output. +! The sparse matrix structure containing the local submatrix +! to be factorized. Note that a is intent(inout), and not only +! intent(in), since the row and column indices of the matrix +! stored in a are shifted by -1, and then again by +1, by the +! routine mld_cumf_fact, which is an interface to the UMFPACK +! C code performing the factorization. +! desc_a - type(psb_desc_type), input. +! The communication descriptor associated to a. +! p - type(mld_cbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the pointers, +! p%iprcparm(mld_umf_symptr_) and p%iprcparm(mld_umf_numptr_), +! to the data structures used by UMFPACK for computing the LU +! factorization. +! info - integer, output. +! Error code. +! +subroutine mld_cumf_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_cumf_bld + + implicit none + +! Arguments + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: nzt,ictxt,me,np,err_act + integer :: i_err(5) + character(len=20) :: name + + info=0 + name='mld_cumf_bld' + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + if (psb_toupper(a%fida) /= 'CSC') then + info=135 + call psb_errpush(info,name,a_err=a%fida) + goto 9999 + endif + + nzt = psb_sp_get_nnzeros(a) + + ! + ! Compute the LU factorization + ! + call mld_cumf_fact(a%m,nzt,& + & a%aspk,a%ia1,a%ia2,& + & p%iprcparm(mld_umf_symptr_),p%iprcparm(mld_umf_numptr_),info) + + if (info /= 0) then + i_err(1) = info + info=4110 + call psb_errpush(info,name,a_err='mld_umf_fact',i_err=i_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_cumf_bld + + + diff --git a/mlprec/mld_cumf_interface.c b/mlprec/mld_cumf_interface.c new file mode 100644 index 00000000..a9672bb9 --- /dev/null +++ b/mlprec/mld_cumf_interface.c @@ -0,0 +1,258 @@ +/* + * + * MLD2P4 version 1.0 + * MultiLevel Domain Decomposition Parallel Preconditioners Package + * based on PSBLAS (Parallel Sparse BLAS version 2.2) + * + * (C) Copyright 2008 + * + * Salvatore Filippone University of Rome Tor Vergata + * Alfredo Buttari University of Rome Tor Vergata + * Pasqua D'Ambra ICAR-CNR, Naples + * Daniela di Serafino Second University of Naples + * + * 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 MLD2P4 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 MLD2P4 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: mld_cumf_interface.c + * + * Functions: mld_cumf_fact_, mld_cumf_solve_, mld_cumf_free_. + * + * This file is an interface to the UMFPACK routines for sparse factorization and + * solve. It was obtained by adapting umfpack_zi_demo under the original UMFPACK + * copyright terms reproduced below. + * + */ + +/* ===================== +UMFPACK Version 4.4 (Jan. 28, 2005), Copyright (c) 2005 by Timothy A. +Davis. All Rights Reserved. + +UMFPACK License: + + Your use or distribution of UMFPACK or any modified version of + UMFPACK implies that you agree to this License. + + THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY + EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. + + Permission is hereby granted to use or copy this program, provided + that the Copyright, this License, and the Availability of the original + version is retained on all copies. User documentation of any code that + uses UMFPACK or any modified version of UMFPACK code must cite the + Copyright, this License, the Availability note, and "Used by permission." + Permission to modify the code and to distribute modified code is granted, + provided the Copyright, this License, and the Availability note are + retained, and a notice that the code was modified is included. This + software was developed with support from the National Science Foundation, + and is provided to you free of charge. + +Availability: + + http://www.cise.ufl.edu/research/sparse/umfpack + +*/ + + + +#ifdef LowerUnderscore +#define mld_cumf_fact_ mld_cumf_fact_ +#define mld_cumf_solve_ mld_cumf_solve_ +#define mld_cumf_free_ mld_cumf_free_ +#endif +#ifdef LowerDoubleUnderscore +#define mld_cumf_fact_ mld_cumf_fact__ +#define mld_cumf_solve_ mld_cumf_solve__ +#define mld_cumf_free_ mld_cumf_free__ +#endif +#ifdef LowerCase +#define mld_cumf_fact_ mld_cumf_fact +#define mld_cumf_solve_ mld_cumf_solve +#define mld_cumf_free_ mld_cumf_free +#endif +#ifdef UpperUnderscore +#define mld_cumf_fact_ MLD_CUMF_FACT_ +#define mld_cumf_solve_ MLD_CUMF_SOLVE_ +#define mld_cumf_free_ MLD_CUMF_FREE_ +#endif +#ifdef UpperDoubleUnderscore +#define mld_cumf_fact_ MLD_CUMF_FACT__ +#define mld_cumf_solve_ MLD_CUMF_SOLVE__ +#define mld_cumf_free_ MLD_CUMF_FREE__ +#endif +#ifdef UpperCase +#define mld_cumf_fact_ MLD_CUMF_FACT +#define mld_cumf_solve_ MLD_CUMF_SOLVE +#define mld_cumf_free_ MLD_CUMF_FREE +#endif + + +#include +/* No single complex in UMFPACK */ +#ifdef Have_UMF_ +#undef Have_UMF_ +#endif + +#ifdef Have_UMF_ +#include "umfpack.h" +#endif + +#ifdef Ptr64Bits +typedef long long fptr; +#else +typedef int fptr; /* 32-bit by default */ +#endif + +void +mld_cumf_fact_(int *n, int *nnz, + double *values, int *rowind, int *colptr, +#ifdef Have_UMF_ + fptr *symptr, + fptr *numptr, + +#else + void *symptr, + void *numptr, +#endif + int *info) + +{ + +#ifdef Have_UMF_ + double Info [UMFPACK_INFO], Control [UMFPACK_CONTROL]; + void *Symbolic, *Numeric ; + int i; + + + umfpack_zi_defaults(Control); + + for (i = 0; i <= *n; ++i) --colptr[i]; + for (i = 0; i < *nnz; ++i) --rowind[i]; + *info = umfpack_zi_symbolic (*n, *n, colptr, rowind, values, NULL, &Symbolic, + Control, Info); + + + if ( *info == UMFPACK_OK ) { + *info = 0; + } else { + printf("umfpack_zi_symbolic() error returns INFO= %d\n", *info); + *info = -11; + *numptr = (fptr) NULL; + return; + } + + *symptr = (fptr) Symbolic; + + *info = umfpack_zi_numeric (colptr, rowind, values, NULL, Symbolic, &Numeric, + Control, Info) ; + + + if ( *info == UMFPACK_OK ) { + *info = 0; + *numptr = (fptr) Numeric; + } else { + printf("umfpack_zi_numeric() error returns INFO= %d\n", *info); + *info = -12; + *numptr = (fptr) NULL; + } + + for (i = 0; i <= *n; ++i) ++colptr[i]; + for (i = 0; i < *nnz; ++i) ++rowind[i]; +#else + fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + +void +mld_cumf_solve_(int *itrans, int *n, + double *x, double *b, int *ldb, +#ifdef Have_UMF_ + fptr *numptr, + +#else + void *numptr, +#endif + int *info) + +{ +#ifdef Have_UMF_ + double Info [UMFPACK_INFO], Control [UMFPACK_CONTROL]; + void *Symbolic, *Numeric ; + int i,trans; + + + umfpack_di_defaults(Control); + Control[UMFPACK_IRSTEP]=0; + + + if (*itrans == 0) { + trans = UMFPACK_A; + } else if (*itrans ==1) { + trans = UMFPACK_At; + } else { + trans = UMFPACK_A; + } + + *info = umfpack_zi_solve(trans,NULL,NULL,NULL,NULL, + x,NULL,b,NULL,(void *) *numptr,Control,Info); + +#else + fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif + +} + + +void +mld_cumf_free_( +#ifdef Have_UMF_ + fptr *symptr, + fptr *numptr, + +#else + void *symptr, + void *numptr, +#endif + int *info) + +{ +#ifdef Have_UMF_ + void *Symbolic, *Numeric ; + Symbolic = (void *) *symptr; + Numeric = (void *) *numptr; + + umfpack_zi_free_numeric(&Numeric); + umfpack_zi_free_symbolic(&Symbolic); + *info=0; +#else + fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + diff --git a/mlprec/mld_dmlprec_bld.f90 b/mlprec/mld_dmlprec_bld.f90 index 06d30965..356a8bcc 100644 --- a/mlprec/mld_dmlprec_bld.f90 +++ b/mlprec/mld_dmlprec_bld.f90 @@ -78,7 +78,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info) character(len=20) :: name integer :: ictxt, np, me, err_act - name='psb_dmlprec_bld' + name='mld_dmlprec_bld' if (psb_get_errstatus().ne.0) return call psb_erractionsave(err_act) info = 0 diff --git a/mlprec/mld_dprecset.f90 b/mlprec/mld_dprecset.f90 index 4b4349c5..05b68476 100644 --- a/mlprec/mld_dprecset.f90 +++ b/mlprec/mld_dprecset.f90 @@ -47,7 +47,7 @@ ! For the multilevel preconditioners, the levels are numbered in increasing ! order starting from the finest one, i.e. level 1 is the finest level. ! -! To set character and real parameters, see mld_dprecsetc and mld_dprecsetd, +! To set character and real parameters, see mld_dprecsetc and mld_dprecsetr, ! respectively. ! ! @@ -249,7 +249,7 @@ end subroutine mld_dprecseti ! For the multilevel preconditioners, the levels are numbered in increasing ! order starting from the finest one, i.e. level 1 is the finest level. ! -! To set integer and real parameters, see mld_dprecseti and mld_dprecsetd, +! To set integer and real parameters, see mld_dprecseti and mld_dprecsetr, ! respectively. ! ! @@ -502,7 +502,7 @@ end subroutine mld_dprecsetc ! -! Subroutine: mld_dprecsetd +! Subroutine: mld_dprecsetr ! Version: real ! ! This routine sets the real parameters defining the preconditioner. More @@ -532,10 +532,10 @@ end subroutine mld_dprecsetc ! If nlev is not present, the parameter identified by 'what' ! is set at all the appropriate levels. ! -subroutine mld_dprecsetd(p,what,val,info,ilev) +subroutine mld_dprecsetr(p,what,val,info,ilev) use psb_base_mod - use mld_prec_mod, mld_protect_name => mld_dprecsetd + use mld_prec_mod, mld_protect_name => mld_dprecsetr implicit none @@ -634,4 +634,4 @@ subroutine mld_dprecsetd(p,what,val,info,ilev) endif -end subroutine mld_dprecsetd +end subroutine mld_dprecsetr diff --git a/mlprec/mld_inner_mod.f90 b/mlprec/mld_inner_mod.f90 index e9013bb5..6944dafc 100644 --- a/mlprec/mld_inner_mod.f90 +++ b/mlprec/mld_inner_mod.f90 @@ -40,6 +40,18 @@ module mld_inner_mod use mld_prec_type use mld_basep_bld_mod interface mld_baseprec_aply + subroutine mld_sbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine mld_sbaseprec_aply subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -52,6 +64,18 @@ module mld_inner_mod real(psb_dpk_),target :: work(:) integer, intent(out) :: info end subroutine mld_dbaseprec_aply + subroutine mld_cbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine mld_cbaseprec_aply subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -67,6 +91,18 @@ module mld_inner_mod end interface interface mld_as_aply + subroutine mld_sas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine mld_sas_aply subroutine mld_das_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -79,6 +115,18 @@ module mld_inner_mod real(psb_dpk_),target :: work(:) integer, intent(out) :: info end subroutine mld_das_aply + subroutine mld_cas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine mld_cas_aply subroutine mld_zas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -94,6 +142,18 @@ module mld_inner_mod end interface interface mld_mlprec_aply + subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: baseprecv(:) + real(psb_spk_),intent(in) :: alpha,beta + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + character :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine mld_smlprec_aply subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -106,6 +166,18 @@ module mld_inner_mod real(psb_dpk_),target :: work(:) integer, intent(out) :: info end subroutine mld_dmlprec_aply + subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: baseprecv(:) + complex(psb_spk_),intent(in) :: alpha,beta + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + character :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine mld_cmlprec_aply subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -122,6 +194,18 @@ module mld_inner_mod interface mld_sub_aply + subroutine mld_ssub_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: prec + real(psb_spk_),intent(in) :: 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, intent(out) :: info + end subroutine mld_ssub_aply subroutine mld_dsub_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -134,6 +218,18 @@ module mld_inner_mod real(psb_dpk_),target,intent(inout) :: work(:) integer, intent(out) :: info end subroutine mld_dsub_aply + subroutine mld_csub_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: 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, intent(out) :: info + end subroutine mld_csub_aply subroutine mld_zsub_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -150,6 +246,18 @@ module mld_inner_mod interface mld_sub_solve + subroutine mld_ssub_solve(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: prec + real(psb_spk_),intent(in) :: 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, intent(out) :: info + end subroutine mld_ssub_solve subroutine mld_dsub_solve(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -162,6 +270,18 @@ module mld_inner_mod real(psb_dpk_),target,intent(inout) :: work(:) integer, intent(out) :: info end subroutine mld_dsub_solve + subroutine mld_csub_solve(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use mld_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(mld_cbaseprc_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: 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, intent(out) :: info + end subroutine mld_csub_solve subroutine mld_zsub_solve(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_base_mod use mld_prec_type @@ -178,6 +298,18 @@ module mld_inner_mod interface mld_asmat_bld + Subroutine mld_sasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) + use psb_base_mod + use mld_prec_type + integer, intent(in) :: ptype,novr + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_sspmat_type), Intent(out) :: blk + Type(psb_desc_type), Intent(inout) :: desc_p + Type(psb_desc_type), Intent(in) :: desc_data + Character, Intent(in) :: upd + integer, intent(out) :: info + character(len=5), optional :: outfmt + end Subroutine mld_sasmat_bld Subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) use psb_base_mod use mld_prec_type @@ -190,6 +322,18 @@ module mld_inner_mod integer, intent(out) :: info character(len=5), optional :: outfmt end Subroutine mld_dasmat_bld + Subroutine mld_casmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) + use psb_base_mod + use mld_prec_type + integer, intent(in) :: ptype,novr + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_cspmat_type), Intent(out) :: blk + Type(psb_desc_type), Intent(inout) :: desc_p + Type(psb_desc_type), Intent(in) :: desc_data + Character, Intent(in) :: upd + integer, intent(out) :: info + character(len=5), optional :: outfmt + end Subroutine mld_casmat_bld Subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) use psb_base_mod use mld_prec_type @@ -205,6 +349,14 @@ module mld_inner_mod end interface interface mld_sp_renum + subroutine mld_ssp_renum(a,blck,p,atmp,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(in) :: a,blck + type(psb_sspmat_type), intent(out) :: atmp + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_ssp_renum subroutine mld_dsp_renum(a,blck,p,atmp,info) use psb_base_mod use mld_prec_type @@ -213,6 +365,14 @@ module mld_inner_mod type(mld_dbaseprc_type), intent(inout) :: p integer, intent(out) :: info end subroutine mld_dsp_renum + subroutine mld_csp_renum(a,blck,p,atmp,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(in) :: a,blck + type(psb_cspmat_type), intent(out) :: atmp + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_csp_renum subroutine mld_zsp_renum(a,blck,p,atmp,info) use psb_base_mod use mld_prec_type @@ -224,6 +384,15 @@ module mld_inner_mod end interface interface mld_aggrmap_bld + subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) + use psb_base_mod + use mld_prec_type + integer, intent(in) :: aggr_type + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in) :: desc_a + integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) + integer, intent(out) :: info + end subroutine mld_saggrmap_bld subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) use psb_base_mod use mld_prec_type @@ -233,6 +402,15 @@ module mld_inner_mod integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, intent(out) :: info end subroutine mld_daggrmap_bld + subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) + use psb_base_mod + use mld_prec_type + integer, intent(in) :: aggr_type + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in) :: desc_a + integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) + integer, intent(out) :: info + end subroutine mld_caggrmap_bld subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) use psb_base_mod use mld_prec_type @@ -245,6 +423,16 @@ module mld_inner_mod end interface interface mld_aggrmat_asb + subroutine mld_saggrmat_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_sbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + end subroutine mld_saggrmat_asb subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info) use psb_base_mod use mld_prec_type @@ -255,6 +443,16 @@ module mld_inner_mod type(mld_dbaseprc_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_daggrmat_asb + subroutine mld_caggrmat_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_cbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + end subroutine mld_caggrmat_asb subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info) use psb_base_mod use mld_prec_type @@ -268,6 +466,16 @@ module mld_inner_mod end interface interface mld_aggrmat_raw_asb + subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_sbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + end subroutine mld_saggrmat_raw_asb subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) use psb_base_mod use mld_prec_type @@ -278,6 +486,16 @@ module mld_inner_mod type(mld_dbaseprc_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_daggrmat_raw_asb + subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_cbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + end subroutine mld_caggrmat_raw_asb subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) use psb_base_mod use mld_prec_type @@ -291,6 +509,16 @@ module mld_inner_mod end interface interface mld_aggrmat_smth_asb + subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_prec_type + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_sbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + end subroutine mld_saggrmat_smth_asb subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info) use psb_base_mod use mld_prec_type @@ -301,6 +529,16 @@ module mld_inner_mod type(mld_dbaseprc_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_daggrmat_smth_asb + subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_prec_type + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_cbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + end subroutine mld_caggrmat_smth_asb subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info) use psb_base_mod use mld_prec_type diff --git a/mlprec/mld_prec_mod.f90 b/mlprec/mld_prec_mod.f90 index 48eb584f..b80df25b 100644 --- a/mlprec/mld_prec_mod.f90 +++ b/mlprec/mld_prec_mod.f90 @@ -48,6 +48,14 @@ module mld_prec_mod use mld_prec_type interface mld_precinit + subroutine mld_sprecinit(p,ptype,info,nlev) + use psb_base_mod + use mld_prec_type + type(mld_sprec_type), intent(inout) :: p + character(len=*), intent(in) :: ptype + integer, intent(out) :: info + integer, optional, intent(in) :: nlev + end subroutine mld_sprecinit subroutine mld_dprecinit(p,ptype,info,nlev) use psb_base_mod use mld_prec_type @@ -56,6 +64,14 @@ module mld_prec_mod integer, intent(out) :: info integer, optional, intent(in) :: nlev end subroutine mld_dprecinit + subroutine mld_cprecinit(p,ptype,info,nlev) + use psb_base_mod + use mld_prec_type + type(mld_cprec_type), intent(inout) :: p + character(len=*), intent(in) :: ptype + integer, intent(out) :: info + integer, optional, intent(in) :: nlev + end subroutine mld_cprecinit subroutine mld_zprecinit(p,ptype,info,nlev) use psb_base_mod use mld_prec_type @@ -67,6 +83,33 @@ module mld_prec_mod end interface interface mld_precset + subroutine mld_sprecseti(p,what,val,info,ilev) + use psb_base_mod + use mld_prec_type + type(mld_sprec_type), intent(inout) :: p + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + end subroutine mld_sprecseti + subroutine mld_sprecsetr(p,what,val,info,ilev) + use psb_base_mod + use mld_prec_type + type(mld_sprec_type), intent(inout) :: p + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + end subroutine mld_sprecsetr + subroutine mld_sprecsetc(p,what,string,info,ilev) + use psb_base_mod + use mld_prec_type + type(mld_sprec_type), intent(inout) :: p + integer, intent(in) :: what + character(len=*), intent(in) :: string + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + end subroutine mld_sprecsetc subroutine mld_dprecseti(p,what,val,info,ilev) use psb_base_mod use mld_prec_type @@ -76,7 +119,7 @@ module mld_prec_mod integer, intent(out) :: info integer, optional, intent(in) :: ilev end subroutine mld_dprecseti - subroutine mld_dprecsetd(p,what,val,info,ilev) + subroutine mld_dprecsetr(p,what,val,info,ilev) use psb_base_mod use mld_prec_type type(mld_dprec_type), intent(inout) :: p @@ -84,7 +127,7 @@ module mld_prec_mod real(psb_dpk_), intent(in) :: val integer, intent(out) :: info integer, optional, intent(in) :: ilev - end subroutine mld_dprecsetd + end subroutine mld_dprecsetr subroutine mld_dprecsetc(p,what,string,info,ilev) use psb_base_mod use mld_prec_type @@ -94,6 +137,33 @@ module mld_prec_mod integer, intent(out) :: info integer, optional, intent(in) :: ilev end subroutine mld_dprecsetc + subroutine mld_cprecseti(p,what,val,info,ilev) + use psb_base_mod + use mld_prec_type + type(mld_cprec_type), intent(inout) :: p + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + end subroutine mld_cprecseti + subroutine mld_cprecsetr(p,what,val,info,ilev) + use psb_base_mod + use mld_prec_type + type(mld_cprec_type), intent(inout) :: p + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + end subroutine mld_cprecsetr + subroutine mld_cprecsetc(p,what,string,info,ilev) + use psb_base_mod + use mld_prec_type + type(mld_cprec_type), intent(inout) :: p + integer, intent(in) :: what + character(len=*), intent(in) :: string + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + end subroutine mld_cprecsetc subroutine mld_zprecseti(p,what,val,info,ilev) use psb_base_mod use mld_prec_type @@ -103,7 +173,7 @@ module mld_prec_mod integer, intent(out) :: info integer, optional, intent(in) :: ilev end subroutine mld_zprecseti - subroutine mld_zprecsetd(p,what,val,info,ilev) + subroutine mld_zprecsetr(p,what,val,info,ilev) use psb_base_mod use mld_prec_type type(mld_zprec_type), intent(inout) :: p @@ -111,7 +181,7 @@ module mld_prec_mod real(psb_dpk_), intent(in) :: val integer, intent(out) :: info integer, optional, intent(in) :: ilev - end subroutine mld_zprecsetd + end subroutine mld_zprecsetr subroutine mld_zprecsetc(p,what,string,info,ilev) use psb_base_mod use mld_prec_type @@ -124,12 +194,24 @@ module mld_prec_mod end interface interface mld_precfree + subroutine mld_sprecfree(p,info) + use psb_base_mod + use mld_prec_type + type(mld_sprec_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_sprecfree subroutine mld_dprecfree(p,info) use psb_base_mod use mld_prec_type type(mld_dprec_type), intent(inout) :: p integer, intent(out) :: info end subroutine mld_dprecfree + subroutine mld_cprecfree(p,info) + use psb_base_mod + use mld_prec_type + type(mld_cprec_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine mld_cprecfree subroutine mld_zprecfree(p,info) use psb_base_mod use mld_prec_type @@ -139,6 +221,26 @@ module mld_prec_mod end interface interface mld_precaply + subroutine mld_sprec_aply(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine mld_sprec_aply + subroutine mld_sprec_aply1(prec,x,desc_data,info,trans) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine mld_sprec_aply1 subroutine mld_dprec_aply(prec,x,y,desc_data,info,trans,work) use psb_base_mod use mld_prec_type @@ -159,6 +261,26 @@ module mld_prec_mod integer, intent(out) :: info character(len=1), optional :: trans end subroutine mld_dprec_aply1 + subroutine mld_cprec_aply(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine mld_cprec_aply + subroutine mld_cprec_aply1(prec,x,desc_data,info,trans) + use psb_base_mod + use mld_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine mld_cprec_aply1 subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans,work) use psb_base_mod use mld_prec_type @@ -182,6 +304,16 @@ module mld_prec_mod end interface interface mld_precbld + subroutine mld_sprecbld(a,desc_a,prec,info) + use psb_base_mod + use mld_prec_type + implicit none + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_sprec_type), intent(inout) :: prec + integer, intent(out) :: info +!!$ character, intent(in),optional :: upd + end subroutine mld_sprecbld subroutine mld_dprecbld(a,desc_a,prec,info) use psb_base_mod use mld_prec_type @@ -192,6 +324,16 @@ module mld_prec_mod integer, intent(out) :: info !!$ character, intent(in),optional :: upd end subroutine mld_dprecbld + subroutine mld_cprecbld(a,desc_a,prec,info) + use psb_base_mod + use mld_prec_type + implicit none + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_cprec_type), intent(inout) :: prec + integer, intent(out) :: info +!!$ character, intent(in),optional :: upd + end subroutine mld_cprecbld subroutine mld_zprecbld(a,desc_a,prec,info) use psb_base_mod use mld_prec_type diff --git a/mlprec/mld_prec_type.f90 b/mlprec/mld_prec_type.f90 index d69a01b8..e839fd84 100644 --- a/mlprec/mld_prec_type.f90 +++ b/mlprec/mld_prec_type.f90 @@ -62,8 +62,10 @@ module mld_prec_type ! This reduces the size of .mod file. Without the ONLY clause compilation ! blows up on some systems. ! - use psb_base_mod, only : psb_dspmat_type, psb_zspmat_type, psb_desc_type,& - & psb_inter_desc_type, psb_sizeof, psb_dpk_ + use psb_base_mod, only :& + & psb_dspmat_type, psb_zspmat_type,& + & psb_sspmat_type, psb_cspmat_type,& + & psb_desc_type, psb_inter_desc_type, psb_sizeof, psb_dpk_, psb_spk_ ! ! Type: mld_dprec_type, mld_zprec_type @@ -158,6 +160,25 @@ module mld_prec_type ! iprcparm(mld_umf_ptr) or iprcparm(mld_slu_ptr), respectively. ! + type mld_sbaseprc_type + + type(psb_sspmat_type), allocatable :: av(:) + real(psb_spk_), allocatable :: d(:) + type(psb_desc_type) :: desc_data , desc_ac + integer, allocatable :: iprcparm(:) + real(psb_spk_), allocatable :: rprcparm(:) + integer, allocatable :: perm(:), invperm(:) + integer, allocatable :: mlia(:), nlaggr(:) + type(psb_sspmat_type), pointer :: base_a => null() + type(psb_desc_type), pointer :: base_desc => null() + real(psb_spk_), allocatable :: dorig(:) + type(psb_inter_desc_type) :: map_desc + end type mld_sbaseprc_type + + type mld_sprec_type + type(mld_sbaseprc_type), allocatable :: baseprecv(:) + end type mld_sprec_type + type mld_dbaseprc_type type(psb_dspmat_type), allocatable :: av(:) @@ -177,6 +198,25 @@ module mld_prec_type type(mld_dbaseprc_type), allocatable :: baseprecv(:) end type mld_dprec_type + type mld_cbaseprc_type + + type(psb_cspmat_type), allocatable :: av(:) + complex(psb_spk_), allocatable :: d(:) + type(psb_desc_type) :: desc_data , desc_ac + integer, allocatable :: iprcparm(:) + real(psb_spk_), allocatable :: rprcparm(:) + integer, allocatable :: perm(:), invperm(:) + integer, allocatable :: mlia(:), nlaggr(:) + type(psb_cspmat_type), pointer :: base_a => null() + type(psb_desc_type), pointer :: base_desc => null() + complex(psb_spk_), allocatable :: dorig(:) + type(psb_inter_desc_type) :: map_desc + end type mld_cbaseprc_type + + type mld_cprec_type + type(mld_cbaseprc_type), allocatable :: baseprecv(:) + end type mld_cprec_type + type mld_zbaseprc_type type(psb_zspmat_type), allocatable :: av(:) @@ -325,20 +365,24 @@ module mld_prec_type ! interface mld_base_precfree - module procedure mld_dbase_precfree, mld_zbase_precfree + module procedure mld_sbase_precfree, mld_cbase_precfree,& + & mld_dbase_precfree, mld_zbase_precfree end interface interface mld_nullify_baseprec - module procedure mld_nullify_dbaseprec, mld_nullify_zbaseprec + module procedure mld_nullify_sbaseprec, mld_nullify_cbaseprec,& + & mld_nullify_dbaseprec, mld_nullify_zbaseprec end interface interface mld_check_def - module procedure mld_icheck_def, mld_dcheck_def + module procedure mld_icheck_def, mld_scheck_def, mld_dcheck_def end interface interface mld_prec_descr module procedure mld_out_prec_descr, mld_file_prec_descr, & - & mld_zout_prec_descr, mld_zfile_prec_descr + & mld_zout_prec_descr, mld_zfile_prec_descr,& + & mld_sout_prec_descr, mld_sfile_prec_descr,& + & mld_cout_prec_descr, mld_cfile_prec_descr end interface interface mld_prec_short_descr @@ -346,7 +390,9 @@ module mld_prec_type end interface interface mld_sizeof - module procedure mld_dprec_sizeof, mld_zprec_sizeof, & + module procedure mld_sprec_sizeof, mld_cprec_sizeof, & + & mld_dprec_sizeof, mld_zprec_sizeof, & + & mld_sbaseprc_sizeof, mld_cbaseprc_sizeof,& & mld_dbaseprc_sizeof, mld_zbaseprc_sizeof end interface @@ -356,12 +402,26 @@ contains ! Function returning the size of the mld_prec_type data structure ! + function mld_sprec_sizeof(prec) + use psb_base_mod + type(mld_sprec_type), intent(in) :: prec + integer :: mld_dprec_sizeof + integer :: val,i + val = 0 + if (allocated(prec%baseprecv)) then + do i=1, size(prec%baseprecv) + val = val + mld_sizeof(prec%baseprecv(i)) + end do + end if + mld_sprec_sizeof = val + end function mld_sprec_sizeof + function mld_dprec_sizeof(prec) use psb_base_mod type(mld_dprec_type), intent(in) :: prec integer :: mld_dprec_sizeof integer :: val,i - val = 8 + val = 0 if (allocated(prec%baseprecv)) then do i=1, size(prec%baseprecv) val = val + mld_sizeof(prec%baseprecv(i)) @@ -370,6 +430,20 @@ contains mld_dprec_sizeof = val end function mld_dprec_sizeof + function mld_cprec_sizeof(prec) + use psb_base_mod + type(mld_cprec_type), intent(in) :: prec + integer :: mld_cprec_sizeof + integer :: val,i + val = 0 + if (allocated(prec%baseprecv)) then + do i=1, size(prec%baseprecv) + val = val + mld_sizeof(prec%baseprecv(i)) + end do + end if + mld_cprec_sizeof = val + end function mld_cprec_sizeof + function mld_zprec_sizeof(prec) use psb_base_mod type(mld_zprec_type), intent(in) :: prec @@ -388,6 +462,43 @@ contains ! Function returning the size of the mld_baseprc_type data structure ! + function mld_sbaseprc_sizeof(prec) + use psb_base_mod + type(mld_sbaseprc_type), intent(in) :: prec + integer :: mld_dbaseprc_sizeof + integer :: val,i + + val = 0 + if (allocated(prec%iprcparm)) then + val = val + psb_sizeof_int * size(prec%iprcparm) + if (prec%iprcparm(mld_prec_status_) == mld_prec_built_) then + select case(prec%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_ilu_t_) + ! do nothing + case(mld_slu_) + case(mld_umf_) + case(mld_sludist_) + case default + end select + + end if + end if + if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm) + if (allocated(prec%d)) val = val + psb_sizeof_sp * size(prec%d) + if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) + if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) + val = val + psb_sizeof(prec%desc_data) + if (allocated(prec%av)) then + do i=1,size(prec%av) + val = val + psb_sizeof(prec%av(i)) + end do + end if + val = val + psb_sizeof(prec%map_desc) + + mld_sbaseprc_sizeof = val + + end function mld_sbaseprc_sizeof + function mld_dbaseprc_sizeof(prec) use psb_base_mod type(mld_dbaseprc_type), intent(in) :: prec @@ -396,7 +507,7 @@ contains val = 0 if (allocated(prec%iprcparm)) then - val = val + 4 * size(prec%iprcparm) + val = val + psb_sizeof_int * size(prec%iprcparm) if (prec%iprcparm(mld_prec_status_) == mld_prec_built_) then select case(prec%iprcparm(mld_sub_solve_)) case(mld_ilu_n_,mld_ilu_t_) @@ -425,6 +536,43 @@ contains end function mld_dbaseprc_sizeof + function mld_cbaseprc_sizeof(prec) + use psb_base_mod + type(mld_cbaseprc_type), intent(in) :: prec + integer :: mld_zbaseprc_sizeof + integer :: val,i + + val = 0 + if (allocated(prec%iprcparm)) then + val = val + psb_sizeof_int * size(prec%iprcparm) + if (prec%iprcparm(mld_prec_status_) == mld_prec_built_) then + select case(prec%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_ilu_t_) + ! do nothing + case(mld_slu_) + case(mld_umf_) + case(mld_sludist_) + case default + end select + + end if + end if + if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm) + if (allocated(prec%d)) val = val + 2 * psb_sizeof_sp * size(prec%d) + if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) + if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) + val = val + psb_sizeof(prec%desc_data) + if (allocated(prec%av)) then + do i=1,size(prec%av) + val = val + psb_sizeof(prec%av(i)) + end do + end if + val = val + psb_sizeof(prec%map_desc) + + mld_cbaseprc_sizeof = val + + end function mld_cbaseprc_sizeof + function mld_zbaseprc_sizeof(prec) use psb_base_mod type(mld_zbaseprc_type), intent(in) :: prec @@ -433,7 +581,7 @@ contains val = 0 if (allocated(prec%iprcparm)) then - val = val + 4 * size(prec%iprcparm) + val = val + psb_sizeof_int * size(prec%iprcparm) if (prec%iprcparm(mld_prec_status_) == mld_prec_built_) then select case(prec%iprcparm(mld_sub_solve_)) case(mld_ilu_n_,mld_ilu_t_) @@ -488,6 +636,17 @@ contains type(mld_zprec_type), intent(in) :: p call mld_zfile_prec_descr(6,p) end subroutine mld_zout_prec_descr + subroutine mld_sout_prec_descr(p) + use psb_base_mod + type(mld_sprec_type), intent(in) :: p + call mld_sfile_prec_descr(6,p) + end subroutine mld_sout_prec_descr + + subroutine mld_cout_prec_descr(p) + use psb_base_mod + type(mld_cprec_type), intent(in) :: p + call mld_cfile_prec_descr(6,p) + end subroutine mld_cout_prec_descr ! ! Subroutine: mld_file_prec_descr @@ -607,6 +766,111 @@ contains end subroutine mld_file_prec_descr + subroutine mld_sfile_prec_descr(iout,p) + + use psb_base_mod + + ! Arguments + integer, intent(in) :: iout + type(mld_sprec_type), intent(in) :: p + + ! Local variables + integer :: ilev + character(len=20), parameter :: name='mld_file_prec_descr' + + write(iout,*) 'Preconditioner description' + if (allocated(p%baseprecv)) then + if (size(p%baseprecv)>=1) then + ilev = 1 + write(iout,*) 'Base preconditioner' + select case(p%baseprecv(ilev)%iprcparm(mld_prec_type_)) + case(mld_noprec_) + write(iout,*) 'No preconditioning' + case(mld_diag_) + write(iout,*) 'Diagonal scaling' + case(mld_bjac_) + write(iout,*) 'Block Jacobi with: ',& + & fact_names(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + select case(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_) + write(iout,*) 'Fill level:',p%baseprecv(ilev)%iprcparm(mld_sub_fill_in_) + case(mld_ilu_t_) + write(iout,*) 'Fill threshold :',p%baseprecv(ilev)%rprcparm(mld_fact_thrs_) + case(mld_slu_,mld_umf_,mld_sludist_) + case default + write(iout,*) 'Should never get here!' + end select + case(mld_as_) + write(iout,*) 'Additive Schwarz with: ',& + & fact_names(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + select case(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_) + write(iout,*) 'Fill level:',p%baseprecv(ilev)%iprcparm(mld_sub_fill_in_) + case(mld_ilu_t_) + write(iout,*) 'Fill threshold :',p%baseprecv(ilev)%rprcparm(mld_fact_thrs_) + case(mld_slu_,mld_umf_,mld_sludist_) + case default + write(iout,*) 'Should never get here!' + end select + write(iout,*) 'Overlap:',& + & p%baseprecv(ilev)%iprcparm(mld_n_ovr_) + write(iout,*) 'Restriction: ',& + & restrict_names(p%baseprecv(ilev)%iprcparm(mld_sub_restr_)) + write(iout,*) 'Prolongation: ',& + & prolong_names(p%baseprecv(ilev)%iprcparm(mld_sub_prol_)) + end select + end if + if (size(p%baseprecv)>=2) then + do ilev = 2, size(p%baseprecv) + if (.not.allocated(p%baseprecv(ilev)%iprcparm)) then + write(iout,*) 'Inconsistent MLPREC part!' + return + endif + + write(iout,*) 'Multilevel: Level No', ilev + write(iout,*) 'Multilevel type: ',& + & ml_names(p%baseprecv(ilev)%iprcparm(mld_ml_type_)) + if (p%baseprecv(ilev)%iprcparm(mld_ml_type_)>mld_no_ml_) then + write(iout,*) 'Multilevel aggregation: ', & + & aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_)) + write(iout,*) 'Aggregation smoothing: ', & + & aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_)) + if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then + write(iout,*) 'Damping omega: ', & + & p%baseprecv(ilev)%rprcparm(mld_aggr_damp_) + write(iout,*) 'Multilevel smoother position: ',& + & smooth_names(p%baseprecv(ilev)%iprcparm(mld_smooth_pos_)) + end if + write(iout,*) 'Coarse matrix: ',& + & matrix_names(p%baseprecv(ilev)%iprcparm(mld_coarse_mat_)) + if (allocated(p%baseprecv(ilev)%nlaggr)) then + write(iout,*) 'Sizes of aggregates: ', & + & sum( p%baseprecv(ilev)%nlaggr(:)),' : ',p%baseprecv(ilev)%nlaggr(:) + end if + write(iout,*) 'Factorization type: ',& + & fact_names(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + select case(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_) + write(iout,*) 'Fill level:',p%baseprecv(ilev)%iprcparm(mld_sub_fill_in_) + case(mld_ilu_t_) + write(iout,*) 'Fill threshold :',p%baseprecv(ilev)%rprcparm(mld_fact_thrs_) + case(mld_slu_,mld_umf_,mld_sludist_) + case default + write(iout,*) 'Should never get here!' + end select + write(iout,*) 'Number of Jacobi sweeps: ', & + & (p%baseprecv(ilev)%iprcparm(mld_smooth_sweeps_)) + end if + end do + end if + + else + write(iout,*) trim(name),': Error: No Base preconditioner available, something is wrong!' + return + endif + + end subroutine mld_sfile_prec_descr + function mld_prec_short_descr(p) use psb_base_mod type(mld_dprec_type), intent(in) :: p @@ -733,6 +997,111 @@ contains end subroutine mld_zfile_prec_descr + subroutine mld_cfile_prec_descr(iout,p) + + use psb_base_mod + + ! Arguments + integer, intent(in) :: iout + type(mld_cprec_type), intent(in) :: p + + ! Local variables + integer :: ilev + character(len=20), parameter :: name='mld_file_prec_descr' + + write(iout,*) 'Preconditioner description' + if (allocated(p%baseprecv)) then + if (size(p%baseprecv)>=1) then + write(iout,*) 'Base preconditioner' + ilev=1 + select case(p%baseprecv(ilev)%iprcparm(mld_prec_type_)) + case(mld_noprec_) + write(iout,*) 'No preconditioning' + case(mld_diag_) + write(iout,*) 'Diagonal scaling' + case(mld_bjac_) + write(iout,*) 'Block Jacobi with: ',& + & fact_names(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + select case(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_) + write(iout,*) 'Fill level:',p%baseprecv(ilev)%iprcparm(mld_sub_fill_in_) + case(mld_ilu_t_) + write(iout,*) 'Fill threshold :',p%baseprecv(ilev)%rprcparm(mld_fact_thrs_) + case(mld_slu_,mld_umf_,mld_sludist_) + case default + write(iout,*) 'Should never get here!' + end select + case(mld_as_) + write(iout,*) 'Additive Schwarz with: ',& + & fact_names(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + select case(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_) + write(iout,*) 'Fill level:',p%baseprecv(ilev)%iprcparm(mld_sub_fill_in_) + case(mld_ilu_t_) + write(iout,*) 'Fill threshold :',p%baseprecv(ilev)%rprcparm(mld_fact_thrs_) + case(mld_slu_,mld_umf_,mld_sludist_) + case default + write(iout,*) 'Should never get here!' + end select + write(iout,*) 'Overlap:',& + & p%baseprecv(ilev)%iprcparm(mld_n_ovr_) + write(iout,*) 'Restriction: ',& + & restrict_names(p%baseprecv(ilev)%iprcparm(mld_sub_restr_)) + write(iout,*) 'Prolongation: ',& + & prolong_names(p%baseprecv(ilev)%iprcparm(mld_sub_prol_)) + end select + end if + if (size(p%baseprecv)>=2) then + do ilev = 2, size(p%baseprecv) + if (.not.allocated(p%baseprecv(ilev)%iprcparm)) then + write(iout,*) 'Inconsistent MLPREC part!' + return + endif + + write(iout,*) 'Multilevel: Level No', ilev + write(iout,*) 'Multilevel type: ',& + & ml_names(p%baseprecv(ilev)%iprcparm(mld_ml_type_)) + if (p%baseprecv(ilev)%iprcparm(mld_ml_type_)>mld_no_ml_) then + write(iout,*) 'Multilevel aggregation: ', & + & aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_)) + write(iout,*) 'Smoother: ', & + & aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_)) + if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then + write(iout,*) 'Smoothing omega: ', & + & p%baseprecv(ilev)%rprcparm(mld_aggr_damp_) + write(iout,*) 'Smoothing position: ',& + & smooth_names(p%baseprecv(ilev)%iprcparm(mld_smooth_pos_)) + end if + write(iout,*) 'Coarse matrix: ',& + & matrix_names(p%baseprecv(ilev)%iprcparm(mld_coarse_mat_)) + if (allocated(p%baseprecv(ilev)%nlaggr)) then + write(iout,*) 'Aggregation sizes: ', & + & sum( p%baseprecv(ilev)%nlaggr(:)),' : ',p%baseprecv(ilev)%nlaggr(:) + end if + write(iout,*) 'Factorization type: ',& + & fact_names(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + select case(p%baseprecv(ilev)%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_) + write(iout,*) 'Fill level:',p%baseprecv(ilev)%iprcparm(mld_sub_fill_in_) + case(mld_ilu_t_) + write(iout,*) 'Fill threshold :',p%baseprecv(ilev)%rprcparm(mld_fact_thrs_) + case(mld_slu_,mld_umf_,mld_sludist_) + case default + write(iout,*) 'Should never get here!' + end select + write(iout,*) 'Number of Jacobi sweeps: ', & + & (p%baseprecv(ilev)%iprcparm(mld_smooth_sweeps_)) + end if + end do + end if + + else + write(iout,*) trim(name),': Error: No Base preconditioner available, something is wrong!' + return + endif + + end subroutine mld_cfile_prec_descr + function mld_zprec_short_descr(p) use psb_base_mod type(mld_zprec_type), intent(in) :: p @@ -871,6 +1240,22 @@ contains return end function is_legal_fact_thrs + function is_legal_s_omega(ip) + use psb_base_mod + real(psb_spk_), intent(in) :: ip + logical :: is_legal_s_omega + is_legal_s_omega = ((ip>=0.0).and.(ip<=2.0)) + return + end function is_legal_s_omega + function is_legal_s_fact_thrs(ip) + use psb_base_mod + real(psb_spk_), intent(in) :: ip + logical :: is_legal_s_fact_thrs + + is_legal_s_fact_thrs = (ip>=0.0) + return + end function is_legal_s_fact_thrs + subroutine mld_icheck_def(ip,name,id,is_legal) use psb_base_mod @@ -892,6 +1277,27 @@ contains end if end subroutine mld_icheck_def + subroutine mld_scheck_def(ip,name,id,is_legal) + use psb_base_mod + real(psb_spk_), intent(inout) :: ip + real(psb_spk_), intent(in) :: id + character(len=*), intent(in) :: name + interface + function is_legal(i) + use psb_base_mod + real(psb_spk_), intent(in) :: i + logical :: is_legal + end function is_legal + end interface + character(len=20), parameter :: rname='mld_check_def' + + if (.not.is_legal(ip)) then + write(0,*)trim(rname),': Error: Illegal value for ',& + & name,' :',ip, '. defaulting to ',id + ip = id + end if + end subroutine mld_scheck_def + subroutine mld_dcheck_def(ip,name,id,is_legal) use psb_base_mod real(psb_dpk_), intent(inout) :: ip @@ -913,6 +1319,94 @@ contains end if end subroutine mld_dcheck_def + subroutine mld_sbase_precfree(p,info) + use psb_base_mod + + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + integer :: i + + info = 0 + + ! Actually we might just deallocate the top level array, except + ! for the inner UMFPACK or SLU stuff + + if (allocated(p%d)) then + deallocate(p%d,stat=info) + end if + + if (allocated(p%av)) then + do i=1,size(p%av) + call psb_sp_free(p%av(i),info) + if (info /= 0) then + ! Actually, we don't care here about this. + ! Just let it go. + ! return + end if + enddo + deallocate(p%av,stat=info) + end if + + if (allocated(p%desc_data%matrix_data)) & + & call psb_cdfree(p%desc_data,info) + if (allocated(p%desc_ac%matrix_data)) & + & call psb_cdfree(p%desc_ac,info) + + if (allocated(p%rprcparm)) then + deallocate(p%rprcparm,stat=info) + end if + ! This is a pointer to something else, must not free it here. + nullify(p%base_a) + ! This is a pointer to something else, must not free it here. + nullify(p%base_desc) + + if (allocated(p%dorig)) then + deallocate(p%dorig,stat=info) + endif + + if (allocated(p%mlia)) then + deallocate(p%mlia,stat=info) + endif + + if (allocated(p%nlaggr)) then + deallocate(p%nlaggr,stat=info) + endif + + if (allocated(p%perm)) then + deallocate(p%perm,stat=info) + endif + + if (allocated(p%invperm)) then + deallocate(p%invperm,stat=info) + endif + + if (allocated(p%iprcparm)) then + if (p%iprcparm(mld_sub_solve_)==mld_slu_) then +!!$ call mld_sslu_free(p%iprcparm(mld_slu_ptr_),info) + end if +!!$ if (p%iprcparm(mld_sub_solve_)==mld_sludist_) then +!!$ call mld_ssludist_free(p%iprcparm(mld_slud_ptr_),info) +!!$ end if +!!$ if (p%iprcparm(mld_sub_solve_)==mld_umf_) then +!!$ call mld_dumf_free(p%iprcparm(mld_umf_symptr_),& +!!$ & p%iprcparm(mld_umf_numptr_),info) +!!$ end if + deallocate(p%iprcparm,stat=info) + end if + call mld_nullify_baseprec(p) + end subroutine mld_sbase_precfree + + subroutine mld_nullify_sbaseprec(p) + use psb_base_mod + + type(mld_sbaseprc_type), intent(inout) :: p + + nullify(p%base_a) + nullify(p%base_desc) + + end subroutine mld_nullify_sbaseprec + + subroutine mld_dbase_precfree(p,info) use psb_base_mod @@ -1000,6 +1494,86 @@ contains end subroutine mld_nullify_dbaseprec + subroutine mld_cbase_precfree(p,info) + use psb_base_mod + type(mld_cbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + integer :: i + + info = 0 + + if (allocated(p%d)) then + deallocate(p%d,stat=info) + end if + + if (allocated(p%av)) then + do i=1,size(p%av) + call psb_sp_free(p%av(i),info) + if (info /= 0) then + ! Actually, we don't care here about this. + ! Just let it go. + ! return + end if + enddo + deallocate(p%av,stat=info) + + end if + if (allocated(p%desc_data%matrix_data)) & + & call psb_cdfree(p%desc_data,info) + if (allocated(p%desc_ac%matrix_data)) & + & call psb_cdfree(p%desc_ac,info) + + if (allocated(p%rprcparm)) then + deallocate(p%rprcparm,stat=info) + end if + ! This is a pointer to something else, must not free it here. + nullify(p%base_a) + ! This is a pointer to something else, must not free it here. + nullify(p%base_desc) + + if (allocated(p%dorig)) then + deallocate(p%dorig,stat=info) + endif + + if (allocated(p%mlia)) then + deallocate(p%mlia,stat=info) + endif + + if (allocated(p%nlaggr)) then + deallocate(p%nlaggr,stat=info) + endif + + if (allocated(p%perm)) then + deallocate(p%perm,stat=info) + endif + + if (allocated(p%invperm)) then + deallocate(p%invperm,stat=info) + endif + + if (allocated(p%iprcparm)) then + if (p%iprcparm(mld_sub_solve_)==mld_slu_) then +!!$ call mld_cslu_free(p%iprcparm(mld_slu_ptr_),info) + end if +!!$ if (p%iprcparm(mld_sub_solve_)==mld_umf_) then +!!$ call mld_zumf_free(p%iprcparm(mld_umf_symptr_),& +!!$ & p%iprcparm(mld_umf_numptr_),info) +!!$ end if + deallocate(p%iprcparm,stat=info) + end if + call mld_nullify_baseprec(p) + end subroutine mld_cbase_precfree + + subroutine mld_nullify_cbaseprec(p) + use psb_base_mod + + type(mld_cbaseprc_type), intent(inout) :: p + + nullify(p%base_a) + nullify(p%base_desc) + + end subroutine mld_nullify_cbaseprec + subroutine mld_zbase_precfree(p,info) use psb_base_mod type(mld_zbaseprc_type), intent(inout) :: p diff --git a/mlprec/mld_saggrmap_bld.f90 b/mlprec/mld_saggrmap_bld.f90 new file mode 100644 index 00000000..f534b541 --- /dev/null +++ b/mlprec/mld_saggrmap_bld.f90 @@ -0,0 +1,390 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_saggrmap_bld.f90 +! +! Subroutine: mld_saggrmap_bld +! Version: real +! +! This routine builds a mapping from the row indices of the fine-level matrix +! to the row indices of the coarse-level matrix, according to a decoupled +! aggregation algorithm. This mapping will be used by mld_aggrmat_asb to +! build the coarse-level matrix. +! +! The aggregation algorithm is a parallel version of that described in +! M. Brezina and P. Vanek, A black-box iterative solver based on a +! two-level Schwarz method, Computing, 63 (1999), 233-263. +! For more details see +! P. D'Ambra, D. di Serafino and S. Filippone, On the development of +! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math. +! 57 (2007), 1181-1196. +! +! +! Arguments: +! aggr_type - integer, input. +! The scalar used to identify the aggregation algorithm. +! a - type(psb_dspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! info - integer, output. +! Error code. +! +subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_saggrmap_bld + + implicit none + + ! Arguments + integer, intent(in) :: aggr_type + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in) :: desc_a + integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) + integer, intent(out) :: info + + ! Local variables + integer, allocatable :: ils(:), neigh(:) + integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m + type(psb_sspmat_type), target :: atmp, atrans + type(psb_sspmat_type), pointer :: apnt + logical :: recovery + integer :: debug_level, debug_unit + integer :: ictxt,np,me,err_act + integer :: nrow, ncol, n_ne + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + name = 'mld_aggrmap_bld' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ! + ! Note. At the time being we are ignoring aggr_type so + ! that we only have decoupled aggregation. This might + ! change in the future. + ! + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + select case (aggr_type) + case (mld_dec_aggr_,mld_sym_dec_aggr_) + + nr = a%m + allocate(ilaggr(nr),neigh(nr),stat=info) + if(info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*nr,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + do i=1, nr + ilaggr(i) = -(nr+1) + end do + if (aggr_type == mld_dec_aggr_) then + apnt => a + else + call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,& + & rscale=.false.,cscale=.false.) + atmp%m=nr + atmp%k=nr + if (info == 0) call psb_transp(atmp,atrans,fmt='COO') + if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.) + atmp%m=nr + atmp%k=nr + if (info == 0) call psb_sp_free(atrans,info) + if (info == 0) call psb_ipcoo2csr(atmp,info) + apnt => atmp + if (info/=0) then + info=4001 + call psb_errpush(info,name,a_err='init apnt') + goto 9999 + end if + + end if + + + ! Note: -(nr+1) Untouched as yet + ! -i 1<=i<=nr Adjacent to aggregate i + ! i 1<=i<=nr Belonging to aggregate i + + ! + ! Phase one: group nodes together. + ! Very simple minded strategy. + ! + naggr = 0 + nlp = 0 + do + icnt = 0 + do i=1, nr + if (ilaggr(i) == -(nr+1)) then + ! + ! 1. Untouched nodes are marked >0 together + ! with their neighbours + ! + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + + call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) + if (info/=0) then + info=4010 + call psb_errpush(info,name,a_err='psb_neigh') + goto 9999 + end if + do k=1, n_ne + j = neigh(k) + if ((1<=j).and.(j<=nr)) then + ilaggr(j) = naggr + endif + enddo + ! + ! 2. Untouched neighbours of these nodes are marked <0. + ! + call psb_neigh(apnt,i,neigh,n_ne,info,lev=2) + if (info/=0) then + info=4010 + call psb_errpush(info,name,a_err='psb_neigh') + goto 9999 + end if + + do n = 1, n_ne + m = neigh(n) + if ((1<=m).and.(m<=nr)) then + if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr + endif + enddo + endif + enddo + nlp = nlp + 1 + if (icnt == 0) exit + enddo + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & ' Check 1:',count(ilaggr == -(nr+1)),& + & (a%ia1(i),i=a%ia2(1),a%ia2(2)-1) + end if + + ! + ! Phase two: sweep over leftovers. + ! + allocate(ils(naggr+10),stat=info) + if(info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + do i=1, size(ils) + ils(i) = 0 + end do + do i=1, nr + n = ilaggr(i) + if (n>0) then + if (n>naggr) then + info=4001 + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') + goto 9999 + else + ils(n) = ils(n) + 1 + end if + + end if + end do + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 1: number of aggregates ',naggr + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 1: nodes aggregated ',sum(ils) + end if + + recovery=.false. + do i=1, nr + if (ilaggr(i) < 0) then + ! + ! Now some silly rule to break ties: + ! Group with smallest adjacent aggregate. + ! + isz = nr+1 + ia = -1 + + call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) + if (info/=0) then + info=4010 + call psb_errpush(info,name,a_err='psb_neigh') + goto 9999 + end if + + do j=1, n_ne + k = neigh(j) + if ((1<=k).and.(k<=nr)) then + n = ilaggr(k) + if (n>0) then + if (n>naggr) then + info=4001 + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') + goto 9999 + end if + + if (ils(n) < isz) then + ia = n + isz = ils(n) + endif + endif + endif + enddo + if (ia == -1) then + if (ilaggr(i) > -(nr+1)) then + ilaggr(i) = abs(ilaggr(i)) + if (ilaggr(I)>naggr) then + info=4001 + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 3 ?') + goto 9999 + end if + ils(ilaggr(i)) = ils(ilaggr(i)) + 1 + ! + ! This might happen if the pattern is non symmetric. + ! Need a better handling. + ! + recovery = .true. + else + info=4001 + call psb_errpush(info,name,a_err='Unrecoverable error !!') + goto 9999 + endif + else + ilaggr(i) = ia + if (ia>naggr) then + info=4001 + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ') + goto 9999 + end if + ils(ia) = ils(ia) + 1 + endif + end if + enddo + if (debug_level >= psb_debug_outer_) then + if (recovery) then + write(debug_unit,*) me,' ',trim(name),& + & 'Had to recover from strange situation in loc_aggregate.' + write(debug_unit,*) me,' ',trim(name),& + & 'Perhaps an unsymmetric pattern?' + endif + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 2: number of aggregates ',naggr,sum(ils) + do i=1, naggr + write(debug_unit,*) me,' ',trim(name),& + & 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i) + enddo + write(debug_unit,*) me,' ',trim(name),& + & maxval(ils(1:naggr)) + write(debug_unit,*) me,' ',trim(name),& + & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' + end if + + if (count(ilaggr<0) >0) then + info=4001 + call psb_errpush(info,name,a_err='Fatal error: some leftovers') + goto 9999 + endif + + deallocate(ils,neigh,stat=info) + if (info/=0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(ncol,ilaggr,info) + if (info/=0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(nlaggr(np),stat=info) + if (info/=0) then + info=4025 + call psb_errpush(info,name,i_err=(/np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + nlaggr(:) = 0 + nlaggr(me+1) = naggr + call psb_sum(ictxt,nlaggr(1:np)) + + if (aggr_type == mld_sym_dec_aggr_) then + call psb_sp_free(atmp,info) + end if + + case default + + info = -1 + call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_saggrmap_bld diff --git a/mlprec/mld_saggrmat_asb.f90 b/mlprec/mld_saggrmat_asb.f90 new file mode 100644 index 00000000..61422945 --- /dev/null +++ b/mlprec/mld_saggrmat_asb.f90 @@ -0,0 +1,160 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_saggrmat_asb.f90 +! +! Subroutine: mld_saggrmat_asb +! Version: real +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using a Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! A mapping from the nodes of the adjacency graph of A to the nodes of the +! adjacency graph of A_C has been computed by the mld_aggrmap_bld subroutine. +! The prolongator P_C is built here from this mapping, according to the +! value of p%iprcparm(mld_aggr_kind_), specified by the user through +! mld_sprecinit and mld_sprecset. +! +! Currently three different prolongators are implemented, corresponding to +! three aggregation algorithms: +! 1. raw aggregation, +! 2. smoothed aggregation, +! 3. "bizarre" aggregation. +! 1. The raw aggregation uses as prolongator the piecewise constant interpolation +! operator corresponding to the fine-to-coarse level mapping built by +! mld_aggrmap_bld. This is called tentative prolongator. +! 2. The smoothed aggregation uses as prolongator the operator obtained by applying +! a damped Jacobi smoother to the tentative prolongator. +! 3. The "bizarre" aggregation uses a prolongator proposed by the authors of MLD2P4. +! This prolongator still requires a deep analysis and testing and its use is +! not recommended. +! +! For more details see +! M. Brezina and P. Vanek, A black-box iterative solver based on a two-level +! Schwarz method, Computing, 63 (1999), 233-263. +! P. D'Ambra, D. di Serafino and S. Filippone, On the development of PSBLAS-based +! parallel two-level Schwarz preconditioners, Appl. Num. Math., 57 (2007), +! 1181-1196. +! +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! ac - type(psb_sspmat_type), output. +! The sparse matrix structure containing the local part of +! the coarse-level matrix. +! desc_ac - type(psb_desc_type), output. +! The communication descriptor of the coarse-level matrix. +! p - type(mld_sbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_saggrmat_asb(a,desc_a,ac,desc_ac,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_saggrmat_asb + + implicit none + +! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_sbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + +! Local variables + integer :: ictxt,np,me, err_act, icomm + character(len=20) :: name + + name='mld_aggrmat_asb' + if(psb_get_errstatus().ne.0) return + info=0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + + call psb_info(ictxt, me, np) + + select case (p%iprcparm(mld_aggr_kind_)) + case (mld_no_smooth_) + + call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_aggrmat_raw_asb') + goto 9999 + end if + + case(mld_smooth_prol_,mld_biz_prol_) + + call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_aggrmat_smth_asb') + goto 9999 + end if + + case default + + call psb_errpush(4001,name,a_err='Invalid aggr kind') + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_saggrmat_asb diff --git a/mlprec/mld_saggrmat_raw_asb.F90 b/mlprec/mld_saggrmat_raw_asb.F90 new file mode 100644 index 00000000..981d5718 --- /dev/null +++ b/mlprec/mld_saggrmat_raw_asb.F90 @@ -0,0 +1,284 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_saggrmat_raw_asb.F90 +! +! Subroutine: mld_saggrmat_raw_asb +! Version: real +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using a Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is the piecewise constant interpolation operator corresponding +! the fine-to-coarse level mapping built by mld_aggrmap_bld. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%iprcparm(mld_coarse_mat_), +! specified by the user through mld_sprecinit and mld_sprecset. +! +! For details see +! P. D'Ambra, D. di Serafino and S. Filippone, On the development of +! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math., +! 57 (2007), 1181-1196. +! +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! ac - type(psb_sspmat_type), output. +! The sparse matrix structure containing the local part of +! the coarse-level matrix. +! desc_ac - type(psb_desc_type), output. +! The communication descriptor of the coarse-level matrix. +! p - type(mld_sbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_saggrmat_raw_asb + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + +! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_sbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + +! Local variables + integer ::ictxt,np,me, err_act, icomm + character(len=20) :: name + type(psb_sspmat_type) :: b + integer, pointer :: nzbr(:), idisp(:) + type(psb_sspmat_type), pointer :: am1,am2 + integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + & naggr, nzt, naggrm1, i + + name='mld_aggrmat_raw_asb' + if(psb_get_errstatus().ne.0) return + info=0 + call psb_erractionsave(err_act) + + call psb_nullify_sp(b) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt, me, np) + nglob = psb_cd_get_global_rows(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + + am2 => p%av(mld_sm_pr_t_) + am1 => p%av(mld_sm_pr_) + call psb_nullify_sp(am1) + call psb_nullify_sp(am2) + + + naggr = p%nlaggr(me+1) + ntaggr = sum(p%nlaggr) + allocate(nzbr(np), idisp(np),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + naggrm1=sum(p%nlaggr(1:me)) + + if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then + do i=1, nrow + p%mlia(i) = p%mlia(i) + naggrm1 + end do + call psb_halo(p%mlia,desc_a,info) + end if + + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_halo') + goto 9999 + end if + + if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then + call psb_sp_all(ncol,ntaggr,am1,ncol,info) + else + call psb_sp_all(ncol,naggr,am1,ncol,info) + end if + + if (info /= 0) then + call psb_errpush(4010,name,a_err='spall') + goto 9999 + end if + + do i=1,nrow + am1%aspk(i) = sone + am1%ia1(i) = i + am1%ia2(i) = p%mlia(i) + end do + am1%infoa(psb_nnz_) = nrow + + call psb_spcnv(am1,info,afmt='csr',dupl=psb_dupl_add_) + call psb_transp(am1,am2) + + + call psb_sp_clip(a,b,info,jmax=nrow) + if(info /= 0) then + call psb_errpush(4010,name,a_err='spclip') + goto 9999 + end if + ! Out from sp_clip is always in COO, but just in case.. + if (psb_tolower(b%fida) /= 'coo') then + call psb_errpush(4010,name,a_err='spclip NOT COO') + goto 9999 + end if + + nzt = psb_sp_get_nnzeros(b) + do i=1, nzt + b%ia1(i) = p%mlia(b%ia1(i)) + b%ia2(i) = p%mlia(b%ia2(i)) + enddo + b%m = naggr + b%k = naggr + ! This is to minimize data exchange + call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) + + if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then + + call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdall') + goto 9999 + end if + + nzbr(:) = 0 + nzbr(me+1) = nzt + call psb_sum(ictxt,nzbr(1:np)) + nzac = sum(nzbr) + + call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_all') + goto 9999 + end if + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + + call mpi_allgatherv(b%aspk,ndx,mpi_real,ac%aspk,nzbr,idisp,& + & mpi_real,icomm,info) + call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& + & mpi_integer,icomm,info) + call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& + & mpi_integer,icomm,info) + if(info /= 0) then + info=-1 + call psb_errpush(info,name) + goto 9999 + end if + + ac%m = ntaggr + ac%k = ntaggr + ac%infoa(psb_nnz_) = nzac + ac%fida='COO' + ac%descra='GUN' + call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_free') + goto 9999 + end if + + else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then + + call psb_cdall(ictxt,desc_ac,info,nl=naggr) + if (info == 0) call psb_cdasb(desc_ac,info) + if (info == 0) call psb_sp_clone(b,ac,info) + if(info /= 0) then + call psb_errpush(4001,name,a_err='Build ac, desc_ac') + goto 9999 + end if + call psb_sp_free(b,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_free') + goto 9999 + end if + + else + info = 4001 + call psb_errpush(4001,name,a_err='invalid mld_coarse_mat_') + goto 9999 + end if + + deallocate(nzbr,idisp) + + call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4010,name,a_err='ipcoo2csr') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_saggrmat_raw_asb diff --git a/mlprec/mld_saggrmat_smth_asb.F90 b/mlprec/mld_saggrmat_smth_asb.F90 new file mode 100644 index 00000000..0b00e056 --- /dev/null +++ b/mlprec/mld_saggrmat_smth_asb.F90 @@ -0,0 +1,666 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_saggrmat_smth_asb.F90 +! +! Subroutine: mld_saggrmat_smth_asb +! Version: real +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using a Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! The prolongator P_C is built according to a smoothed aggregation algorithm, +! i.e. it is obtained by applying a damped Jacobi smoother to the piecewise +! constant interpolation operator P corresponding to the fine-to-coarse level +! mapping built by the mld_aggrmap_bld subroutine: +! +! P_C = (I - omega*D^(-1)A) * P, +! +! where D is the diagonal matrix with main diagonal equal to the main diagonal +! of A, and omega is a suitable smoothing parameter. An estimate of the spectral +! radius of D^(-1)A, to be used in the computation of omega, is provided, +! according to the value of p%iprcparm(mld_aggr_eig_), specified by the user +! through mld_sprecinit and mld_sprecset. +! +! This routine can also build A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%iprcparm(mld_coarse_mat_), +! specified by the user through mld_sprecinit and mld_sprecset. +! +! For more details see +! M. Brezina and P. Vanek, A black-box iterative solver based on a +! two-level Schwarz method, Computing, 63 (1999), 233-263. +! P. D'Ambra, D. di Serafino and S. Filippone, On the development of +! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math. +! 57 (2007), 1181-1196. +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! ac - type(psb_sspmat_type), output. +! The sparse matrix structure containing the local part of +! the coarse-level matrix. +! desc_ac - type(psb_desc_type), output. +! The communication descriptor of the coarse-level matrix. +! p - type(mld_sbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_saggrmat_smth_asb + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + +! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(out) :: ac + type(psb_desc_type), intent(out) :: desc_ac + type(mld_sbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + +! Local variables + type(psb_sspmat_type) :: b + integer, pointer :: nzbr(:), idisp(:) + integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k + integer ::ictxt,np,me, err_act, icomm + character(len=20) :: name + type(psb_sspmat_type), pointer :: am1,am2 + type(psb_sspmat_type) :: am3,am4 + logical :: ml_global_nmb + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_spk_) :: omega, anorm, tmp, dg + + name='mld_aggrmat_smth_asb' + if(psb_get_errstatus().ne.0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + + call psb_nullify_sp(b) + call psb_nullify_sp(am3) + call psb_nullify_sp(am4) + + am2 => p%av(mld_sm_pr_t_) + am1 => p%av(mld_sm_pr_) + call psb_nullify_sp(am1) + call psb_nullify_sp(am2) + + nglob = psb_cd_get_global_rows(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + naggr = p%nlaggr(me+1) + ntaggr = sum(p%nlaggr) + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + + naggrm1 = sum(p%nlaggr(1:me)) + naggrp1 = sum(p%nlaggr(1:me+1)) + ml_global_nmb = ( (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_).or.& + & ( (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_).and.& + & (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_)) ) + + if (ml_global_nmb) then + p%mlia(1:nrow) = p%mlia(1:nrow) + naggrm1 + call psb_halo(p%mlia,desc_a,info) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_halo') + goto 9999 + end if + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(p%dorig(nrow),stat=info) + + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + ! Get diagonal D + call psb_sp_getdiag(a,p%dorig,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_getdiag') + goto 9999 + end if + + do i=1,size(p%dorig) + if (p%dorig(i) /= szero) then + p%dorig(i) = sone / p%dorig(i) + else + p%dorig(i) = sone + end if + end do + + ! 1. Allocate Ptilde in sparse matrix form + am4%fida='COO' + am4%m=ncol + if (ml_global_nmb) then + am4%k=ntaggr + call psb_sp_all(ncol,ntaggr,am4,ncol,info) + else + am4%k=naggr + call psb_sp_all(ncol,naggr,am4,ncol,info) + endif + + if (info /= 0) then + call psb_errpush(4010,name,a_err='spall') + goto 9999 + end if + + if (ml_global_nmb) then + do i=1,ncol + am4%aspk(i) = sone + am4%ia1(i) = i + am4%ia2(i) = p%mlia(i) + end do + am4%infoa(psb_nnz_) = ncol + else + do i=1,nrow + am4%aspk(i) = sone + am4%ia1(i) = i + am4%ia2(i) = p%mlia(i) + end do + am4%infoa(psb_nnz_) = nrow + endif + + + call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_) + if (info==0) call psb_spcnv(a,am3,info,afmt='csr',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='spcnv') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies done.' + + ! + ! WARNING: the cycles below assume that AM3 does have + ! its diagonal elements stored explicitly!!! + ! Should we switch to something safer? + ! + call psb_sp_scal(am3,p%dorig,info) + if (info /= 0) goto 9999 + + if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then + + if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then + + ! + ! This only works with CSR. + ! + if (psb_toupper(am3%fida)=='CSR') then + anorm = szero + dg = sone + do i=1,am3%m + tmp = szero + do j=am3%ia2(i),am3%ia2(i+1)-1 + if (am3%ia1(j) <= am3%m) then + tmp = tmp + abs(am3%aspk(j)) + endif + if (am3%ia1(j) == i ) then + dg = abs(am3%aspk(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + else + info = 4001 + endif + else + anorm = psb_spnrmi(am3,desc_a,info) + endif + if (info /= 0) then + call psb_errpush(4001,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + p%rprcparm(mld_aggr_damp_) = omega + + else if (p%iprcparm(mld_aggr_eig_) == mld_user_choice_) then + + omega = p%rprcparm(mld_aggr_damp_) + + else if (p%iprcparm(mld_aggr_eig_) /= mld_user_choice_) then + info = 4001 + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + + if (psb_toupper(am3%fida)=='CSR') then + do i=1,am3%m + do j=am3%ia2(i),am3%ia2(i+1)-1 + if (am3%ia1(j) == i) then + am3%aspk(j) = sone - omega*am3%aspk(j) + else + am3%aspk(j) = - omega*am3%aspk(j) + end if + end do + end do + else + call psb_errpush(4001,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! am1 = (i-wDA)Ptilde + ! Doing it this way means to consider diag(Ai) + ! + ! + call psb_symbmm(am3,am4,am1,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(am3,am4,am1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + call psb_sp_free(am4,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='sp_free') + goto 9999 + end if + + if (ml_global_nmb) then + ! + ! Now we have to gather the halo of am1, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(am1,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == 0) call psb_rwextd(ncol,am1,info,b=am4) + if (info == 0) call psb_sp_free(am4,info) + else + call psb_rwextd(ncol,am1,info) + endif + if(info /= 0) then + call psb_errpush(4001,name,a_err='Halo of am1') + goto 9999 + end if + + call psb_symbmm(a,am1,am3,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,am1,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2' + + if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then + call psb_transp(am1,am2,fmt='COO') + nzl = am2%infoa(psb_nnz_) + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in p%mlia(:) + ! + do k=1, nzl + if ((naggrm1 < am2%ia1(k)) .and.(am2%ia1(k) <= naggrp1)) then + i = i+1 + am2%aspk(i) = am2%aspk(k) + am2%ia1(i) = am2%ia1(k) + am2%ia2(i) = am2%ia2(k) + end if + end do + am2%infoa(psb_nnz_) = i + call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) + if (info /=0) then + call psb_errpush(4010,name,a_err='spcnv am2') + goto 9999 + end if + else + call psb_transp(am1,am2) + endif + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then + ! am2 = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == 0) call psb_rwextd(ncol,am3,info,b=am4) + if (info == 0) call psb_sp_free(am4,info) + else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then + call psb_rwextd(ncol,am3,info) + endif + if(info /= 0) then + call psb_errpush(4001,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(am2,am3,b,info) + if (info == 0) call psb_numbmm(am2,am3,b) + if (info == 0) call psb_sp_free(am3,info) + if (info == 0) call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Build b = am2 x am3') + goto 9999 + end if + + + + select case(p%iprcparm(mld_aggr_kind_)) + + case(mld_smooth_prol_) + + select case(p%iprcparm(mld_coarse_mat_)) + + case(mld_distr_mat_) + + call psb_sp_clone(b,ac,info) + nzac = ac%infoa(psb_nnz_) + nzl = ac%infoa(psb_nnz_) + if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1)) + if (info == 0) call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info) + if (info == 0) call psb_cdasb(desc_ac,info) + if (info == 0) call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I') + if (info == 0) call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I') + if (info /= 0) then + call psb_errpush(4001,name,a_err='Creating desc_ac and converting ac') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + + + ac%m=desc_ac%matrix_data(psb_n_row_) + ac%k=desc_ac%matrix_data(psb_n_col_) + ac%fida='COO' + ac%descra='GUN' + + call psb_sp_free(b,info) + if (info == 0) deallocate(nzbr,idisp,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + if (np>1) then + nzl = psb_sp_get_nnzeros(am1) + call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I') + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_glob_to_loc') + goto 9999 + end if + endif + am1%k=desc_ac%matrix_data(psb_n_col_) + + if (np>1) then + call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_) + nzl = am2%infoa(psb_nnz_) + if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I') + if (info == 0) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4001,name,a_err='Converting am2 to local') + goto 9999 + end if + end if + am2%m=desc_ac%matrix_data(psb_n_col_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) + nzbr(:) = 0 + nzbr(me+1) = b%infoa(psb_nnz_) + + call psb_sum(ictxt,nzbr(1:np)) + nzac = sum(nzbr) + if (info == 0) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) + if (info /= 0) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + + call mpi_allgatherv(b%aspk,ndx,mpi_real,ac%aspk,nzbr,idisp,& + & mpi_real,icomm,info) + if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& + & mpi_integer,icomm,info) + + if (info /= 0) then + call psb_errpush(4001,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + + ac%m = ntaggr + ac%k = ntaggr + ac%infoa(psb_nnz_) = nzac + ac%fida='COO' + ac%descra='GUN' + call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) + if(info /= 0) goto 9999 + call psb_sp_free(b,info) + if(info /= 0) goto 9999 + + deallocate(nzbr,idisp,stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 + end select + + + case(mld_biz_prol_) + + select case(p%iprcparm(mld_coarse_mat_)) + + case(mld_distr_mat_) + + call psb_sp_clone(b,ac,info) + if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=naggr) + if (info == 0) call psb_cdasb(desc_ac,info) + if (info == 0) call psb_sp_free(b,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Build desc_ac, ac') + goto 9999 + end if + + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdall') + goto 9999 + end if + + nzbr(:) = 0 + nzbr(me+1) = b%infoa(psb_nnz_) + call psb_sum(ictxt,nzbr(1:np)) + nzac = sum(nzbr) + call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_sp_all') + goto 9999 + end if + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + + call mpi_allgatherv(b%aspk,ndx,mpi_real,ac%aspk,nzbr,idisp,& + & mpi_real,icomm,info) + if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + + + ac%m = ntaggr + ac%k = ntaggr + ac%infoa(psb_nnz_) = nzac + ac%fida='COO' + ac%descra='GUN' + call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4010,name,a_err='spcnv') + goto 9999 + end if + call psb_sp_free(b,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 + end select + + deallocate(nzbr,idisp,stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') + goto 9999 + + end select + + call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_) + if(info /= 0) then + call psb_errpush(4010,name,a_err='spcnv') + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_saggrmat_smth_asb diff --git a/mlprec/mld_sas_aply.f90 b/mlprec/mld_sas_aply.f90 new file mode 100644 index 00000000..42834d1e --- /dev/null +++ b/mlprec/mld_sas_aply.f90 @@ -0,0 +1,407 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sas_aply.f90 +! +! Subroutine: mld_sas_aply +! Version: real +! +! This routine applies the Additive Schwarz preconditioner by computing +! +! Y = beta*Y + alpha*op(K^(-1))*X, +! where +! - K is the base preconditioner, stored in prec, +! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! +! Arguments: +! alpha - real(psb_spk_), input. +! The scalar alpha. +! prec - type(mld_sbaseprc_type), input. +! The base preconditioner data structure containing the local part +! of the preconditioner K. +! x - real(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - real(psb_spk_), input. +! The scalar beta. +! y - real(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(K^(-1)) = K^(-1); +! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). +! work - real(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +subroutine mld_sas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_sas_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col, int_err(5), nrow_d + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,isz, err_act + character(len=20) :: name, ch_err + character :: trans_ + + name='mld_sas_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_data) + + call psb_info(ictxt, me, np) + + trans_ = psb_toupper(trans) + + select case(prec%iprcparm(mld_prec_type_)) + + case(mld_bjac_) + + call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) + if (info /= 0) then + info=4010 + ch_err='mld_sub_aply' + goto 9999 + end if + + case(mld_as_) + ! + ! Additive Schwarz preconditioner + ! + + if ((prec%iprcparm(mld_n_ovr_)==0).or.(np==1)) then + ! + ! Shortcut: this fixes performance for RAS(0) == BJA + ! + call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) + if(info /= 0) then + info=4010 + ch_err='mld_sub_aply' + goto 9999 + end if + + else + ! + ! Overlap > 0 + ! + + n_row = psb_cd_get_local_rows(prec%desc_data) + n_col = psb_cd_get_local_cols(prec%desc_data) + nrow_d = psb_cd_get_local_rows(desc_data) + isz=max(n_row,N_COL) + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + endif + + tx(1:nrow_d) = x(1:nrow_d) + tx(nrow_d+1:isz) = szero + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx==x) + ! + if (prec%iprcparm(mld_sub_restr_)==psb_halo_) then + call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /=0) then + info=4010 + ch_err='psb_halo' + goto 9999 + end if + else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then + call psb_errpush(4001,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + ! + ! If required, reorder tx according to the row/column permutation of the + ! local extended matrix, stored into the permutation vector prec%perm + ! + if (prec%iprcparm(mld_sub_ren_)>0) then + call psb_gelp('n',prec%perm,tx,info) + if(info /=0) then + info=4010 + ch_err='psb_gelp' + goto 9999 + end if + endif + + ! + ! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the + ! block-Jacobi solver can be applied at the coarsest level of a multilevel + ! preconditioner). The resulting vector is ty. + ! + call mld_sub_aply(sone,prec,tx,szero,ty,prec%desc_data,trans_,aux,info) + if(info /= 0) then + info=4010 + ch_err='mld_bjac_aply' + goto 9999 + end if + + ! + ! Apply to ty the inverse permutation of prec%perm + ! + if (prec%iprcparm(mld_sub_ren_)>0) then + call psb_gelp('n',prec%invperm,ty,info) + if(info /= 0) then + info=4010 + ch_err='psb_gelp' + goto 9999 + end if + endif + + select case (prec%iprcparm(mld_sub_prol_)) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,prec%desc_data,info,& + ! & update=prec%iprcparm(mld_sub_prol_),work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,prec%desc_data,info,& + & update=prec%iprcparm(mld_sub_prol_),work=aux) + if(info /=0) then + info=4010 + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(4001,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (prec%iprcparm(mld_sub_prol_)) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /=0) then + info=4010 + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,prec%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /=0) then + info=4010 + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /=0) then + info=4010 + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(4001,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + ! + ! If required, reorder tx according to the row/column permutation of the + ! local extended matrix, stored into the permutation vector prec%perm + ! + if (prec%iprcparm(mld_sub_ren_)>0) then + call psb_gelp('n',prec%perm,tx,info) + if(info /=0) then + info=4010 + ch_err='psb_gelp' + goto 9999 + end if + endif + + ! + ! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the + ! block-Jacobi solver can be applied at the coarsest level of a multilevel + ! preconditioner). The resulting vector is ty. + ! + call mld_sub_aply(sone,prec,tx,szero,ty,prec%desc_data,trans_,aux,info) + if(info /= 0) then + info=4010 + ch_err='mld_bjac_aply' + goto 9999 + end if + + ! + ! Apply to ty the inverse permutation of prec%perm + ! + if (prec%iprcparm(mld_sub_ren_)>0) then + call psb_gelp('n',prec%invperm,ty,info) + if(info /= 0) then + info=4010 + ch_err='psb_gelp' + goto 9999 + end if + endif + + ! + ! With transpose, we have to do it here + ! + if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then + call psb_ovrl(ty,prec%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /=0) then + info=4010 + ch_err='psb_ovrl' + goto 9999 + end if + else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then + call psb_errpush(4001,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=40 + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + ! + ! Compute y = beta*y + alpha*ty (ty==K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + end if + + case default + + call psb_errpush(4001,name,a_err='Invalid mld_prec_type_') + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_sas_aply + diff --git a/mlprec/mld_sas_bld.f90 b/mlprec/mld_sas_bld.f90 new file mode 100644 index 00000000..abbb0638 --- /dev/null +++ b/mlprec/mld_sas_bld.f90 @@ -0,0 +1,287 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sas_bld.f90 +! +! Subroutine: mld_sas_bld +! Version: real +! +! This routine builds Additive Schwarz (AS) preconditioners. If the AS +! preconditioner is actually the block-Jacobi one, the routine makes only a +! copy of the descriptor of the original matrix and then calls mld_fact_bld +! to perform an LU or ILU factorization of the diagonal blocks of the +! distributed matrix. +! +! +! Arguments: +! a - type(psb_dspmat_type), input. +! The sparse matrix structure containing the local part of the +! matrix to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the sparse matrix a. +! p - type(mld_sbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the local +! part of the preconditioner or solver to be built. +! upd - character, input. +! If upd='F' then the preconditioner is built from scratch; +! if upd=T' then the matrix to be preconditioned has the same +! sparsity pattern of a matrix that has been previously +! preconditioned, hence some information is reused in building +! the new preconditioner. +! info - integer, output. +! Error code. +! +subroutine mld_sas_bld(a,desc_a,p,upd,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_sas_bld + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + type(mld_sbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + integer, intent(out) :: info + + ! Local variables + integer :: ptype,novr + integer :: icomm + Integer :: np,me,nnzero,ictxt, int_err(5),& + & tot_recv, n_row,n_col,nhalo, err_act, data_ + type(psb_sspmat_type) :: blck + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='mld_as_bld' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + If (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' start ', upd + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + + Call psb_info(ictxt, me, np) + + tot_recv=0 + + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + nnzero = psb_sp_get_nnzeros(a) + nhalo = n_col-n_row + ptype = p%iprcparm(mld_prec_type_) + novr = p%iprcparm(mld_n_ovr_) + + select case (ptype) + + case(mld_bjac_) + ! + ! Block Jacobi + ! + data_ = psb_no_comm_ + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling desccpy' + if (upd == 'F') then + call psb_cdcpy(desc_a,p%desc_data,info) + If(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done cdcpy' + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Early return: P>=3 N_OVR=0' + endif + call psb_sp_all(0,0,blck,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + blck%fida = 'COO' + blck%infoa(psb_nnz_) = 0 + + call mld_fact_bld(a,p,upd,info,blck=blck) + + if (info /= 0) then + info=4010 + ch_err='mld_fact_bld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + case(mld_as_) + ! + ! Additive Schwarz + ! + if (novr < 0) then + info=3 + int_err(1)=novr + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + if ((novr == 0).or.(np==1)) then + ! + ! Actually, this is just block Jacobi + ! + data_ = psb_no_comm_ + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling desccpy' + if (upd == 'F') then + call psb_cdcpy(desc_a,p%desc_data,info) + If(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done cdcpy' + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Early return: P>=3 N_OVR=0' + endif + call psb_sp_all(0,0,blck,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + blck%fida = 'COO' + blck%infoa(psb_nnz_) = 0 + + else + + If (upd == 'F') Then + ! + ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). + ! This is done by psb_cdbldext (interface to psb_cdovr), which is + ! independent of CSR, and has been placed in the tools directory + ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it + ! might be used independently of the AS preconditioner, to build + ! a descriptor for an extended stencil in a PDE solver. + ! + call psb_cdbldext(a,desc_a,novr,p%desc_data,info,extype=psb_ovt_asov_) + if(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' From cdbldext _:',p%desc_data%matrix_data(psb_n_row_),& + & p%desc_data%matrix_data(psb_n_col_) + + if (info /= 0) then + info=4010 + ch_err='psb_cdbldext' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + Endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Before sphalo ',blck%fida,blck%m,psb_nnz_,blck%infoa(psb_nnz_) + + ! + ! Retrieve the remote sparse matrix rows required for the AS extended + ! matrix + data_ = psb_comm_ext_ + Call psb_sphalo(a,p%desc_data,blck,info,data=data_,rowscale=.true.) + + if (info /= 0) then + info=4010 + ch_err='psb_sphalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'After psb_sphalo ',& + & blck%fida,blck%m,psb_nnz_,blck%infoa(psb_nnz_) + + End if + + + call mld_fact_bld(a,p,upd,info,blck=blck) + + if (info /= 0) then + info=4010 + ch_err='mld_fact_bld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case default + + info=4001 + ch_err='Invalid ptype' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + End select + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),'Done' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + Return + +End Subroutine mld_sas_bld + diff --git a/mlprec/mld_sbaseprec_aply.f90 b/mlprec/mld_sbaseprec_aply.f90 new file mode 100644 index 00000000..ffebe76b --- /dev/null +++ b/mlprec/mld_sbaseprec_aply.f90 @@ -0,0 +1,189 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sbaseprec_aply.f90 +! +! Subroutine: mld_sbaseprec_aply +! Version: real +! +! This routine applies a base preconditioner by computing +! +! Y = beta*Y + alpha*op(K^(-1))*X, +! where +! - K is the base preconditioner, stored in prec, +! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! The routine is used by mld_smlprec_aply, to apply the multilevel preconditioners, +! or directly by mld_sprec_aply, to apply the basic one-level preconditioners (diagonal, +! block-Jacobi or additive Schwarz). It also manages the case of no preconditioning. +! +! +! Arguments: +! alpha - real(psb_spk_), input. +! The scalar alpha. +! prec - type(mld_sbaseprc_type), input. +! The base preconditioner data structure containing the local part +! of the preconditioner K. +! x - real(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - real(psb_spk_), input. +! The scalar beta. +! y - real(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(K^(-1)) = K^(-1); +! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). +! work - real(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +subroutine mld_sbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_sbaseprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + real(psb_spk_), pointer :: ww(:) + integer :: ictxt, np, me, err_act + integer :: n_row, int_err(5) + character(len=20) :: name, ch_err + character :: trans_ + + name='mld_sbaseprec_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_data) + + call psb_info(ictxt, me, np) + + trans_= psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + info=40 + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + select case(prec%iprcparm(mld_prec_type_)) + + case(mld_noprec_) + ! + ! No preconditioner + ! + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + + case(mld_diag_) + ! + ! Diagonal preconditioner + ! + + if (size(work) >= size(x)) then + ww => work + else + allocate(ww(size(x)),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + end if + + n_row = psb_cd_get_local_rows(desc_data) + ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + if (size(work) < size(x)) then + deallocate(ww,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Deallocate') + goto 9999 + end if + end if + + case(mld_bjac_,mld_as_) + ! + ! Additive Schwarz preconditioner + ! + call mld_as_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) + if(info /= 0) then + info=4010 + ch_err='mld_as_aply' + goto 9999 + end if + + case default + call psb_errpush(4001,name,a_err='Invalid mld_prec_type_') + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_sbaseprec_aply + diff --git a/mlprec/mld_sbaseprec_bld.f90 b/mlprec/mld_sbaseprec_bld.f90 new file mode 100644 index 00000000..0a6c5349 --- /dev/null +++ b/mlprec/mld_sbaseprec_bld.f90 @@ -0,0 +1,217 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sbaseprec_bld.f90 +! +! Subroutine: mld_sbaseprc_bld +! Version: real +! +! This routine builds a 'base preconditioner' related to a matrix A. +! In a multilevel framework, it is called by mld_mlprec_bld to build the +! base preconditioner at each level. +! +! Details on the base preconditioner to be built are stored in the iprcparm +! field of the preconditioner data structure (for a description of this +! data structure see mld_prec_type.f90). +! +! +! Arguments: +! a - type(psb_sspmat_type). +! The sparse matrix structure containing the local part of the +! matrix A to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_sbaseprec_type), input/output. +! The 'base preconditioner' data structure containing the local +! part of the preconditioner at the selected level. +! info - integer, output. +! Error code. +! upd - character, input, optional. +! If upd='F' then the base preconditioner is built from +! scratch; if upd=T' then the matrix to be preconditioned +! has the same sparsity pattern of a matrix that has been +! previously preconditioned, hence some information is reused +! in building the new preconditioner. +! +subroutine mld_sbaseprc_bld(a,desc_a,p,info,upd) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_sbaseprc_bld + + Implicit None + + ! Arguments + type(psb_sspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_sbaseprc_type),intent(inout) :: p + integer, intent(out) :: info + character, intent(in), optional :: upd + + ! Local variables + Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act + character :: iupd + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if (psb_get_errstatus() /= 0) return + name = 'mld_sbaseprc_bld' + info=0 + err=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + if (present(upd)) then + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),'UPD ', upd + if ((psb_toupper(UPD) == 'F').or.(psb_toupper(UPD) == 'T')) then + IUPD=psb_toupper(UPD) + else + IUPD='F' + endif + else + IUPD='F' + endif + + ! + ! Should add check to ensure all procs have the same... + ! + + call mld_check_def(p%iprcparm(mld_prec_type_),'base_prec',& + & mld_diag_,is_legal_base_prec) + + + call psb_nullify_desc(p%desc_data) + + select case(p%iprcparm(mld_prec_type_)) + + case (mld_noprec_) + ! No preconditioner + + ! Do nothing + call psb_cdcpy(desc_a,p%desc_data,info) + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case (mld_diag_) + ! Diagonal preconditioner + + call mld_diag_bld(a,desc_a,p,info) + if(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out of mld_diag_bld' + if(info /= 0) then + info=4010 + ch_err='mld_diag_bld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(mld_bjac_,mld_as_) + ! Additive Schwarz preconditioners/smoothers + + call mld_check_def(p%iprcparm(mld_n_ovr_),'overlap',& + & 0,is_legal_n_ovr) + call mld_check_def(p%iprcparm(mld_sub_restr_),'restriction',& + & psb_halo_,is_legal_restrict) + call mld_check_def(p%iprcparm(mld_sub_prol_),'prolongator',& + & psb_none_,is_legal_prolong) + call mld_check_def(p%iprcparm(mld_sub_ren_),'renumbering',& + & mld_renum_none_,is_legal_renum) + call mld_check_def(p%iprcparm(mld_sub_solve_),'fact',& + & mld_ilu_n_,is_legal_ml_fact) + + ! Set parameters for using SuperLU_dist on the local submatrices + if (p%iprcparm(mld_sub_solve_)==mld_sludist_) then + p%iprcparm(mld_n_ovr_) = 0 + p%iprcparm(mld_smooth_sweeps_) = 1 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': Calling mld_as_bld' + + ! Build the local part of the base preconditioner/smoother + call mld_as_bld(a,desc_a,p,iupd,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='mld_as_bld') + goto 9999 + end if + + case default + + info=4001 + ch_err='Unknown mld_prec_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + end select + + p%base_a => a + p%base_desc => desc_a + p%iprcparm(mld_prec_status_) = mld_prec_built_ + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Done' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_sbaseprc_bld + diff --git a/mlprec/mld_sdiag_bld.f90 b/mlprec/mld_sdiag_bld.f90 new file mode 100644 index 00000000..53ccd0c8 --- /dev/null +++ b/mlprec/mld_sdiag_bld.f90 @@ -0,0 +1,159 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sdiag_bld.f90 +! +! Subroutine: mld_sdiag_bld +! Version: real +! +! This routine builds the diagonal preconditioner corresponding to a given +! sparse matrix A. +! +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local part of the +! matrix A to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor associated to the sparse matrix A. +! p - type(mld_sbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the local +! part of the diagonal preconditioner. +! info - integer, output. +! Error code. +! +subroutine mld_sdiag_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_sdiag_bld + + Implicit None + +! Arguments + type(psb_sspmat_type), target :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_sbaseprc_type),intent(inout) :: p + integer, intent(out) :: info + +! Local variables + Integer :: err_act,ictxt, me, np, n_row, n_col,i + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + name = 'mld_sdiag_bld' + info = 0 + ictxt = psb_cd_get_context(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),' Enter' + + call psb_realloc(n_col,p%d,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_realloc') + goto 9999 + end if + + ! + ! Retrieve the diagonal entries of the matrix A + ! + call psb_sp_getdiag(a,p%d,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getdiag' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! + ! Copy into p%desc_data the descriptor associated to A + ! + call psb_cdcpy(desc_a,p%desc_Data,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdcpy') + goto 9999 + end if + + ! + ! The i-th diagonal entry of the preconditioner is set to one if the + ! corresponding entry a_ii of the sparse matrix A is zero; otherwise + ! it is set to one/a_ii + ! + do i=1,n_row + if (p%d(i) == szero) then + p%d(i) = sone + else + p%d(i) = sone/p%d(i) + endif + end do + + if (a%pl(1) /= 0) then + ! + ! Apply the same row permutation as in the sparse matrix A + ! + call psb_gelp('n',a%pl,p%d,info) + if(info /= 0) then + info=4010 + ch_err='psb_gelp' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),'Done' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_sdiag_bld + diff --git a/mlprec/mld_sfact_bld.f90 b/mlprec/mld_sfact_bld.f90 new file mode 100644 index 00000000..609ff09d --- /dev/null +++ b/mlprec/mld_sfact_bld.f90 @@ -0,0 +1,484 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sfact_bld.f90 +! +! Subroutine: mld_sfact_bld +! Version: real +! +! This routine computes an LU or incomplete LU (ILU) factorization of the diagonal +! blocks of a distributed matrix, according to the value of +! p%iprcparm(iprcparm(sub_solve_), set by the user through +! mld_sprecinit or mld_sprecset. +! It may also compute an LU factorization of a distributed matrix, or split +! a distributed matrix into its block-diagonal and off block-diagonal parts, +! for the future application of multiple block-Jacobi sweeps. +! +! This routine is used by mld_as_bld, to build a 'base' block-Jacobi or +! Additive Schwarz (AS) preconditioner at any level of a multilevel preconditioner, +! or a block-Jacobi or LU or ILU solver at the coarsest level of a multilevel +! preconditioner. For the AS preconditioners, the diagonal blocks to be factorized +! are stored into the sparse matrix data structures a and blck, and blck contains +! the remote rows needed to build the extended local matrix as required by the +! AS preconditioner. +! +! More precisely, the routine performs one of the following tasks: +! +! 1. LU or ILU factorization of the diagonal blocks of the distributed matrix +! for the construction of a block-Jacobi or AS preconditioners +! (allowed at any level of a multilevel preconditioner); +! +! 2. setup of block-Jacobi sweeps to compute an approximate solution of a +! linear system +! A*Y = X, +! distributed among the processes (allowed only at the coarsest level); +! +! 3. LU factorization of the matrix of a linear system +! A*Y = X, +! distributed among the processes (allowed only at the coarsest level); +! +! 4. LU or incomplete LU factorization of the matrix of a linear system +! A*Y = X, +! replicated on the processes (allowed only at the coarsest level). +! +! The following factorizations are available: +! - ILU(k), i.e. ILU factorization with fill-in level k; +! - MILU(k), i.e. modified ILU factorization with fill-in level k; +! - ILU(k,t), i.e. ILU with threshold (i.e. drop tolerance) t and k additional +! entries in each row of the L and U factors with respect to the initial +! sparsity pattern; +! - serial LU implemented in SuperLU version 3.0; +! - serial LU implemented in UMFPACK version 4.4; +! - distributed LU implemented in SuperLU_DIST version 2.0. +! +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local part of the +! distributed matrix. +! p - type(mld_sbaseprec_type), input/output. +! The 'base preconditioner' data structure containing the local +! part of the preconditioner or solver at the current level. +! info - integer, output. +! Error code. +! upd - character, input. +! If upd='F' then the preconditioner is built from scratch; +! if upd=T' then the matrix to be preconditioned has the same +! sparsity pattern of a matrix that has been previously +! preconditioned, hence some information is reused in building +! the new preconditioner. +! blck - type(psb_sspmat_type), input, optional. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 blck is empty. +! +subroutine mld_sfact_bld(a,p,upd,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_sfact_bld + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + character, intent(in) :: upd + type(psb_sspmat_type), intent(in), target, optional :: blck + + ! Local Variables + type(psb_sspmat_type), pointer :: blck_ + type(psb_sspmat_type) :: atmp + integer :: ictxt,np,me,err_act + integer :: debug_level, debug_unit + integer :: k, m, int_err(5), n_row, nrow_a, n_col + character :: trans, unitd + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info=0 + name='mld_sfact_bld' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(p%desc_data) + call psb_info(ictxt, me, np) + + m = a%m + if (m < 0) then + info = 10 + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + trans = 'N' + unitd = 'U' + + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info ==0) call psb_sp_all(0,0,blck_,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + blck_%fida = 'COO' + blck_%infoa(psb_nnz_) = 0 + end if + call psb_nullify_sp(atmp) + + ! + ! Treat separately the case the local matrix has to be reordered + ! and the case this is not required. + ! + select case(p%iprcparm(mld_sub_ren_)) + + ! + ! A reordering of the local matrix is required. + ! + case (1:) + + ! + ! Reorder the rows and the columns of the local extended matrix, + ! according to the value of p%iprcparm(sub_ren_). The reordered + ! matrix is stored into atmp, using the COO format. + ! + call mld_sp_renum(a,blck_,p,atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='mld_sp_renum') + goto 9999 + end if + + ! + ! Clip into p%av(ap_nd_) the off block-diagonal part of the local + ! matrix. The clipped matrix is then stored in CSR format. + ! + if (p%iprcparm(mld_smooth_sweeps_) > 1) then + call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,& + & jmin=atmp%m+1,rscale=.false.,cscale=.false.) + if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,& + & afmt='csr',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_spcnv') + goto 9999 + end if + + k = psb_sp_get_nnzeros(p%av(mld_ap_nd_)) + call psb_sum(ictxt,k) + + if (k == 0) then + ! + ! If the off diagonal part is emtpy, there is no point in doing + ! multiple Jacobi sweeps. This is certain to happen when running + ! on a single processor. + ! + p%iprcparm(mld_smooth_sweeps_) = 1 + end if + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' Factoring rows ',& + & atmp%m,a%m,blck_%m,atmp%ia2(atmp%m+1)-1 + + ! + ! Compute a factorization of the diagonal block of the local matrix, + ! according to the choice made by the user by setting p%iprcparm(sub_solve_) + ! + select case(p%iprcparm(mld_sub_solve_)) + + case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + ! + ! ILU(k)/MILU(k)/ILU(k,t) factorization. + ! + call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) + if (info == 0) call mld_ilu_bld(atmp,p,upd,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='mld_ilu_bld') + goto 9999 + end if + + case(mld_slu_) + ! + ! LU factorization through the SuperLU package. + ! + call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) + if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_slu_bld') + goto 9999 + end if + + case(mld_sludist_) + ! + ! LU factorization through the SuperLU_DIST package. This works only + ! when the matrix is distributed among the processes. + ! NOTE: Should have NO overlap here!!!! + ! + call psb_spcnv(a,atmp,info,afmt='csr') + if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_sludist_bld') + goto 9999 + end if + + case(mld_umf_) + ! + ! LU factorization through the UMFPACK package. + ! + call psb_spcnv(atmp,info,afmt='csc',dupl=psb_dupl_add_) + if (info == 0) call mld_umf_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_umf_bld') + goto 9999 + end if + + case(mld_f_none_) + ! + ! Error: no factorization required. + ! + info=4001 + call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_') + goto 9999 + + case default + info=4001 + call psb_errpush(info,name,a_err='Unknown mld_sub_solve_') + goto 9999 + end select + + call psb_sp_free(atmp,info) + + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + ! + ! No reordering of the local matrix is required + ! + case(0) + ! + ! In case of multiple block-Jacobi sweeps, clip into p%av(ap_nd_) + ! the off block-diagonal part of the local extended matrix. The + ! clipped matrix is then stored in CSR format. + ! + + if (p%iprcparm(mld_smooth_sweeps_) > 1) then + n_row = psb_cd_get_local_rows(p%desc_data) + n_col = psb_cd_get_local_cols(p%desc_data) + nrow_a = a%m + ! The following is known to work + ! given that the output from CLIP is in COO. + call psb_sp_clip(a,p%av(mld_ap_nd_),info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == 0) call psb_sp_clip(blck_,atmp,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == 0) call psb_rwextd(n_row,p%av(mld_ap_nd_),info,b=atmp) + if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,& + & afmt='csr',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + + k = psb_sp_get_nnzeros(p%av(mld_ap_nd_)) + call psb_sum(ictxt,k) + + if (k == 0) then + ! + ! If the off block-diagonal part is emtpy, there is no point in doing + ! multiple Jacobi sweeps. This is certain to happen when running + ! on a single processor. + ! + p%iprcparm(mld_smooth_sweeps_) = 1 + end if + call psb_sp_free(atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + end if + ! + ! Compute a factorization of the diagonal block of the local matrix, + ! according to the choice made by the user by setting p%iprcparm(sub_solve_) + ! + select case(p%iprcparm(mld_sub_solve_)) + + case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + ! + ! ILU(k)/MILU(k)/ILU(k,t) factorization. + ! + ! + ! Compute the incomplete LU factorization. + ! + call mld_ilu_bld(a,p,upd,info,blck=blck_) + if (info/=0) then + call psb_errpush(4010,name,a_err='mld_ilu_bld') + goto 9999 + end if + + case(mld_slu_) + ! + ! LU factorization through the SuperLU package. + ! + n_row = psb_cd_get_local_rows(p%desc_data) + n_col = psb_cd_get_local_cols(p%desc_data) + call psb_spcnv(a,atmp,info,afmt='coo') + if (info == 0) call psb_rwextd(n_row,atmp,info,b=blck_) + + ! + ! Compute the LU factorization. + ! + if (info == 0) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) + if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_slu_bld') + goto 9999 + end if + + call psb_sp_free(atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + case(mld_sludist_) + ! + ! LU factorization through the SuperLU_DIST package. This works only + ! when the matrix is distributed among the processes. + ! NOTE: Should have NO overlap here!!!! + ! + call psb_spcnv(a,atmp,info,afmt='csr') + if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_sludist_bld') + goto 9999 + end if + + call psb_sp_free(atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + case(mld_umf_) + ! + ! LU factorization through the UMFPACK package. + ! + + call psb_spcnv(a,atmp,info,afmt='coo') + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_spcnv') + goto 9999 + end if + + n_row = psb_cd_get_local_rows(p%desc_data) + n_col = psb_cd_get_local_cols(p%desc_data) + call psb_rwextd(n_row,atmp,info,b=blck_) + + ! + ! Compute the LU factorization. + ! + if (info == 0) call psb_spcnv(atmp,info,afmt='csc',dupl=psb_dupl_add_) + if (info == 0) call mld_umf_bld(atmp,p%desc_data,p,info) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': Done mld_umf_bld ',info + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_umf_bld') + goto 9999 + end if + + call psb_sp_free(atmp,info) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + + case(mld_f_none_) + ! + ! Error: no factorization required. + ! + info=4001 + call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_') + goto 9999 + + case default + info=4001 + call psb_errpush(info,name,a_err='Unknown mld_sub_solve_') + goto 9999 + end select + + case default + info=4001 + call psb_errpush(info,name,a_err='Invalid renum_') + goto 9999 + end select + + if (.not.present(blck)) then + call psb_sp_free(blck_,info) + if (info == 0) deallocate(blck_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_sp_free') + goto 9999 + end if + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),'End ' + + call psb_erractionrestore(err_act) + + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine mld_sfact_bld + + diff --git a/mlprec/mld_silu0_fact.f90 b/mlprec/mld_silu0_fact.f90 new file mode 100644 index 00000000..593bbc7b --- /dev/null +++ b/mlprec/mld_silu0_fact.f90 @@ -0,0 +1,648 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_silu0_fact.f90 +! +! Subroutine: mld_silu0_fact +! Version: real +! Contains: mld_silu0_factint, ilu_copyin +! +! This routine computes either the ILU(0) or the MILU(0) factorization of the +! diagonal blocks of a distributed matrix. These factorizations +! are used to build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a given level of a multilevel +! preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is CSR. +! The diagonal of the U factor is stored separately (actually, the inverse of the +! diagonal entries is stored; this is then managed in the solve stage associated +! to the ILU(0)/MILU(0) factorization). +! +! The routine copies and factors "on the fly" from a and blck into l (L factor), +! u (U factor, except its diagonal) and d (diagonal of U). +! +! This implementation of ILU(0)/MILU(0) is faster than the implementation in +! mld_siluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). +! +! +! Arguments: +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The MILU(0) factorization is computed if ialg = 2 (= mld_milu_n_); +! the ILU(0) factorization otherwise. +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see mld_as_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_sspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_sspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! d - real(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_sspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see mld_fact_bld), then blck is empty. +! +subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_silu0_fact + + implicit none + + ! Arguments + integer, intent(in) :: ialg + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + real(psb_spk_), intent(inout) :: d(:) + integer, intent(out) :: info + type(psb_sspmat_type),intent(in), optional, target :: blck + + ! Local variables + integer :: l1, l2,m,err_act + type(psb_sspmat_type), pointer :: blck_ + character(len=20) :: name, ch_err + + name='mld_silu0_fact' + info = 0 + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_nullify_sp(blck_) ! Probably pointless. + call psb_sp_all(0,0,blck_,1,info) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + blck_%m=0 + endif + + ! + ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg + ! + call mld_silu0_factint(ialg,m,a%m,a,blck_%m,blck_,& + & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + if(info.ne.0) then + info=4010 + ch_err='mld_silu0_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + l%infoa(1) = l1 + l%fida = 'CSR' + l%descra = 'TLU' + u%infoa(1) = l2 + u%fida = 'CSR' + u%descra = 'TUU' + l%m = m + l%k = m + u%m = m + u%k = m + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call psb_sp_free(blck_,info) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + ! + ! Subroutine: mld_silu0_factint + ! Version: real + ! Note: internal subroutine of mld_silu0_fact. + ! + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' + ! (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a given level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(0)/MILU(0) factorization). + ! + ! The routine copies and factors "on the fly" from the sparse matrix structures a + ! and b into the arrays laspk, uaspk, d (L, U without its diagonal, diagonal of U). + ! + ! + ! Arguments: + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The ILU(0) factorization is computed if ialg = 1 (= mld_ilu_n_), + ! the MILU(0) one if ialg = 2 (= mld_milu_n_); other values + ! are not allowed. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! ma - integer, input + ! The number of rows of the local submatrix stored into a. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see mld_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! mb - integer, input. + ! The number of rows of the local submatrix stored into b. + ! b - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by mld_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been + ! reordered (see mld_fact_bld), then b does not contain any row. + ! d - real(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the + ! incomplete factorization. + ! laspk - real(psb_spk_), dimension(:), input/output. + ! The entries of U are stored according to the CSR format. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uaspk - real(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uaspk, according to the CSR storage format. + ! l1 - integer, output. + ! The number of nonzero entries in laspk. + ! l2 - integer, output. + ! The number of nonzero entries in uaspk. + ! info - integer, output. + ! Error code. + ! + subroutine mld_silu0_factint(ialg,m,ma,a,mb,b,& + & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + + implicit none + + ! Arguments + integer, intent(in) :: ialg + type(psb_sspmat_type),intent(in) :: a,b + integer,intent(inout) :: m,l1,l2,info + integer, intent(in) :: ma,mb + integer, dimension(:), intent(inout) :: lia1,lia2,uia1,uia2 + real(psb_spk_), dimension(:),intent(inout) :: laspk,uaspk,d + + ! Local variables + integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act + real(psb_spk_) :: dia,temp + integer, parameter :: nrb=16 + type(psb_sspmat_type) :: trw + integer :: int_err(5) + character(len=20) :: name, ch_err + + name='mld_silu0_factint' + if(psb_get_errstatus().ne.0) return + info=0 + call psb_erractionsave(err_act) + + select case(ialg) + case(mld_ilu_n_,mld_milu_n_) + ! Ok + case default + info=35 + call psb_errpush(info,name,i_err=(/1,ialg,0,0,0/)) + goto 9999 + end select + + call psb_nullify_sp(trw) + trw%m=0 + trw%k=0 + + call psb_sp_all(trw,1,info) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + lia2(1) = 1 + uia2(1) = 1 + l1 = 0 + l2 = 0 + m = ma+mb + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + d(i) = szero + + if (i <= ma) then + ! + ! Copy the i-th local row of the matrix, stored in a, + ! into laspk/d(i)/uaspk + ! + call ilu_copyin(i,ma,a,i,1,m,l1,lia1,laspk,& + & d(i),l2,uia1,uaspk,ktrw,trw) + else + ! + ! Copy the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row), into laspk/d(i)/uaspk + ! + call ilu_copyin(i-ma,mb,b,i,1,m,l1,lia1,laspk,& + & d(i),l2,uia1,uaspk,ktrw,trw) + endif + + lia2(i+1) = l1 + 1 + uia2(i+1) = l2 + 1 + + dia = d(i) + do kk = lia2(i), lia2(i+1) - 1 + ! + ! Compute entry l(i,k) (lower factor L) of the incomplete + ! factorization + ! + temp = laspk(kk) + k = lia1(kk) + laspk(kk) = temp*d(k) + ! + ! Update the rest of row i (lower and upper factors L and U) + ! using l(i,k) + ! + low1 = kk + 1 + low2 = uia2(i) + ! + updateloop: do jj = uia2(k), uia2(k+1) - 1 + ! + j = uia1(jj) + ! + if (j < i) then + ! + ! search l(i,*) (i-th row of L) for a matching index j + ! + do ll = low1, lia2(i+1) - 1 + l = lia1(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + laspk(ll) = laspk(ll) - temp*uaspk(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + + else if (j == i) then + ! + ! j=i: update the diagonal + ! + dia = dia - temp*uaspk(jj) + cycle updateloop + ! + else if (j > i) then + ! + ! search u(i,*) (i-th row of U) for a matching index j + ! + do ll = low2, uia2(i+1) - 1 + l = uia1(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uaspk(ll) = uaspk(ll) - temp*uaspk(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if + ! + ! If we get here we missed the cycle updateloop, which means + ! that this entry does not match; thus we accumulate on the + ! diagonal for MILU(0). + ! + if (ialg == mld_milu_n_) then + dia = dia - temp*uaspk(jj) + end if + enddo updateloop + enddo + ! + ! Check the pivot size + ! + if (abs(dia) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = 2 + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + dia = sone/dia + end if + d(i) = dia + ! + ! Scale row i of upper triangle + ! + do kk = uia2(i), uia2(i+1) - 1 + uaspk(kk) = uaspk(kk)*dia + enddo + enddo + + call psb_sp_free(trw,info) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mld_silu0_factint + + ! + ! Subroutine: ilu_copyin + ! Version: real + ! Note: internal subroutine of mld_silu0_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type + ! data structure a, into the arrays laspk and uaspk and into the scalar variable + ! dia, corresponding to the lower and upper triangles of A and to the diagonal + ! entry of the row, respectively. The entries in laspk and uaspk are stored + ! according to the CSR format; the corresponding column indices are stored in + ! the arrays lia1 and uia1. + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied into laspk, dia, uaspk row by row, through successive calls to + ! ilu_copyin. + ! + ! The routine is used by mld_silu0_factint in the computation of the ILU(0)/MILU(0) + ! factorization of a local sparse matrix. + ! + ! TODO: modify the routine to allow copying into output L and U that are + ! already filled with indices; this would allow computing an ILU(k) pattern, + ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! Minimum valid column index. + ! jmax - integer, input. + ! Maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! l1 - integer, input/output. + ! Pointer to the last occupied entry of laspk. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the lower triangle + ! copied in laspk row by row (see mld_silu0_factint), according + ! to the CSR storage format. + ! laspk - real(psb_spk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! lower triangle are copied. + ! dia - real(psb_spk_), output. + ! The diagonal entry of the copied row. + ! l2 - integer, input/output. + ! Pointer to the last occupied entry of uaspk. + ! uia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the upper triangle + ! copied in uaspk row by row (see mld_silu0_factint), according + ! to the CSR storage format. + ! uaspk - real(psb_spk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! upper triangle are copied. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_sspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lia1,laspk,& + & dia,l2,uia1,uaspk,ktrw,trw) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(inout) :: trw + integer, intent(in) :: i,m,jd,jmin,jmax + integer, intent(inout) :: ktrw,l1,l2 + integer, intent(inout) :: lia1(:), uia1(:) + real(psb_spk_), intent(inout) :: laspk(:), uaspk(:), dia + + ! Local variables + integer :: k,j,info,irb + integer, parameter :: nrb=16 + character(len=20), parameter :: name='ilu_copyin' + character(len=20) :: ch_err + + if (psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (psb_toupper(a%fida)=='CSR') then + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = a%ia2(i), a%ia2(i+1) - 1 + k = a%ia1(j) + ! write(0,*)'KKKKK',k + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + laspk(l1) = a%aspk(j) + lia1(l1) = k + else if (k == jd) then + dia = a%aspk(j) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uaspk(l2) = a%aspk(j) + uia1(l2) = k + end if + enddo + + else + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into laspk, dia, uaspk, through + ! successive calls to ilu_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb==1)) then + irb = min(m-i+1,nrb) + call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + if(info.ne.0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + laspk(l1) = trw%aspk(ktrw) + lia1(l1) = k + else if (k == jd) then + dia = trw%aspk(ktrw) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uaspk(l2) = trw%aspk(ktrw) + uia1(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine ilu_copyin + +end subroutine mld_silu0_fact diff --git a/mlprec/mld_silu_bld.f90 b/mlprec/mld_silu_bld.f90 new file mode 100644 index 00000000..737355a4 --- /dev/null +++ b/mlprec/mld_silu_bld.f90 @@ -0,0 +1,280 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_silu_bld.f90 +! +! Subroutine: mld_silu_bld +! Version: real +! +! This routine computes an incomplete LU (ILU) factorization of the diagonal +! blocks of a distributed matrix. This factorization is used to build the +! 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz +! preconditioner) corresponding to a certain level of a multilevel preconditioner. +! +! The following factorizations are available: +! - ILU(k), i.e. ILU factorization with fill-in level k, +! - MILU(k), i.e. modified ILU factorization with fill-in level k, +! - ILU(k,t), i.e. ILU with threshold (i.e. drop tolerance) t and k additional +! entries in each row of the L and U factors with respect to the initial +! sparsity pattern. +! Note that the meaning of k in ILU(k,t) is different from that in ILU(k) and +! MILU(k). +! +! For details on the above factorizations see +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! Note that that this routine handles the ILU(0) factorization separately, +! through mld_ilu0_fact, for performance reasons. +! +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if p%iprcparm(mld_n_ovr_) > 0, i.e. the +! 'base' Additive Schwarz preconditioner has overlap greater than +! 0, and p%iprcparm(mld_sub_ren_) = 0, i.e. a reordering of the +! matrix has not been performed (see mld_fact_bld), then a contains +! only the 'original' local part of the distributed matrix, +! i.e. the rows of the matrix held by the calling process according +! to the initial data distribution. +! p - type(mld_sbaseprc_type), input/output. +! The 'base preconditioner' data structure. In input, p%iprcparm +! contains information on the type of factorization to be computed. +! In output, p%av(mld_l_pr_) and p%av(mld_u_pr_) contain the +! incomplete L and U factors (without their diagonals), and p%d +! contains the diagonal of the incomplete U factor. For more +! details on p see its description in mld_prec_type.f90. +! info - integer, output. +! Error code. +! blck - type(psb_sspmat_type), input, optional. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see mld_fact_bld), then blck does not contain any row. +! +subroutine mld_silu_bld(a,p,upd,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_silu_bld + + implicit none + +! Arguments + type(psb_sspmat_type), intent(in), target :: a + type(mld_sbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), optional :: blck + + ! Local Variables + integer :: i, nztota, err_act, n_row, nrow_a + character :: trans, unitd + integer :: debug_level, debug_unit + integer :: ictxt,np,me + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info=0 + name='mld_silu_bld' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(p%desc_data) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + trans = 'N' + unitd = 'U' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + + if (allocated(p%av)) then + if (size(p%av) < mld_bp_ilu_avsz_) then + do i=1,size(p%av) + call psb_sp_free(p%av(i),info) + if (info /= 0) then + ! Actually, we don't care here about this. Just let it go. + ! return + end if + enddo + deallocate(p%av,stat=info) + endif + end if + if (.not.allocated(p%av)) then + allocate(p%av(mld_max_avsz_),stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + endif + + nrow_a = psb_sp_get_nrows(a) + nztota = psb_sp_get_nnzeros(a) + if (present(blck)) then + nztota = nztota + psb_sp_get_nnzeros(blck) + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nztota,a%m,a%k,nrow_a + + n_row = p%desc_data%matrix_data(psb_n_row_) + p%av(mld_l_pr_)%m = n_row + p%av(mld_l_pr_)%k = n_row + p%av(mld_u_pr_)%m = n_row + p%av(mld_u_pr_)%k = n_row + call psb_sp_all(n_row,n_row,p%av(mld_l_pr_),nztota,info) + if (info == 0) call psb_sp_all(n_row,n_row,p%av(mld_u_pr_),nztota,info) + if(info/=0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(p%d)) then + if (size(p%d) < n_row) then + deallocate(p%d) + endif + endif + if (.not.allocated(p%d)) then + allocate(p%d(n_row),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + + select case(p%iprcparm(mld_sub_solve_)) + + case (mld_ilu_t_) + ! + ! ILU(k,t) + ! + + select case(p%iprcparm(mld_sub_fill_in_)) + + case(:-1) + ! Error: fill-in <= -1 + call psb_errpush(30,name,i_err=(/3,p%iprcparm(mld_sub_fill_in_),0,0,0/)) + goto 9999 + + case(0:) + ! Fill-in >= 0 + call mld_ilut_fact(p%iprcparm(mld_sub_fill_in_),p%rprcparm(mld_fact_thrs_),& + & a, p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) + end select + if(info/=0) then + info=4010 + ch_err='mld_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(mld_ilu_n_,mld_milu_n_) + ! + ! ILU(k) and MILU(k) + ! + select case(p%iprcparm(mld_sub_fill_in_)) + case(:-1) + ! Error: fill-in <= -1 + call psb_errpush(30,name,i_err=(/3,p%iprcparm(mld_sub_fill_in_),0,0,0/)) + goto 9999 + case(0) + ! Fill-in 0 + ! Separate implementation of ILU(0) for better performance. + ! There seems to be a problem with the separate implementation of MILU(0), + ! contained into mld_ilu0_fact. This must be investigated. For the time being, + ! resort to the implementation of MILU(k) with k=0. + if (p%iprcparm(mld_sub_solve_) == mld_ilu_n_) then + call mld_ilu0_fact(p%iprcparm(mld_sub_solve_),a,p%av(mld_l_pr_),p%av(mld_u_pr_),& + & p%d,info,blck=blck) + else + call mld_iluk_fact(p%iprcparm(mld_sub_fill_in_),p%iprcparm(mld_sub_solve_),& + & a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) + endif + case(1:) + ! Fill-in >= 1 + ! The same routine implements both ILU(k) and MILU(k) + call mld_iluk_fact(p%iprcparm(mld_sub_fill_in_),p%iprcparm(mld_sub_solve_),& + & a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) + end select + if (info/=0) then + info=4010 + ch_err='mld_iluk_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case default + ! If we end up here, something was wrong up in the call chain. + call psb_errpush(4000,name) + goto 9999 + + end select + + if (psb_sp_getifld(psb_upd_,p%av(mld_u_pr_),info) /= psb_upd_perm_) then + call psb_sp_trim(p%av(mld_u_pr_),info) + endif + + if (psb_sp_getifld(psb_upd_,p%av(mld_l_pr_),info) /= psb_upd_perm_) then + call psb_sp_trim(p%av(mld_l_pr_),info) + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_silu_bld + + diff --git a/mlprec/mld_siluk_fact.f90 b/mlprec/mld_siluk_fact.f90 new file mode 100644 index 00000000..29e138e7 --- /dev/null +++ b/mlprec/mld_siluk_fact.f90 @@ -0,0 +1,971 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_siluk_fact.f90 +! +! Subroutine: mld_siluk_fact +! Version: real +! Contains: mld_siluk_factint, iluk_copyin, iluk_fact, iluk_copyout. +! +! This routine computes either the ILU(k) or the MILU(k) factorization of the +! diagonal blocks of a distributed matrix. These factorizations are used to build +! the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a certain level of a multilevel +! preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in +! the description of the arguments below. The storage format for both the L and +! U factors is CSR. The diagonal of the U factor is stored separately (actually, +! the inverse of the diagonal entries is stored; this is then managed in the solve +! stage associated to the ILU(k)/MILU(k) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in level k in ILU(k)/MILU(k). +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The ILU(k) factorization is computed if ialg = 1 (= mld_ilu_n_); +! the MILU(k) one if ialg = 2 (= mld_milu_n_); other values are +! not allowed. +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see mld_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_sspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_sspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! d - real(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_sspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see mld_fact_bld), then blck does not contain any row. +! +subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_siluk_fact + + implicit none + + ! Arguments + integer, intent(in) :: fill_in, ialg + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + ! Local Variables + integer :: l1, l2, m, err_act + + type(psb_sspmat_type), pointer :: blck_ + character(len=20) :: name, ch_err + + name='mld_siluk_fact' + info = 0 + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_sp_all(0,0,blck_,1,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + + ! + ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg + ! + call mld_siluk_factint(fill_in,ialg,m,a,blck_,& + & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + if (info /= 0) then + info=4010 + ch_err='mld_siluk_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + l%infoa(1) = l1 + l%fida = 'CSR' + l%descra = 'TLU' + u%infoa(1) = l2 + u%fida = 'CSR' + u%descra = 'TUU' + l%m = m + l%k = m + u%m = m + u%k = m + + ! + ! Nullify the pointer / deallocate the memory + ! + if (present(blck)) then + blck_ => null() + else + call psb_sp_free(blck_,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + ! + ! Subroutine: mld_siluk_factint + ! Version: real + ! Note: internal subroutine of mld_siluk_fact + ! + ! This routine computes either the ILU(k) or the MILU(k) factorization of the + ! diagonal blocks of a distributed matrix. These factorizations are used to build + ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k)/MILU(k) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in level k in ILU(k)/MILU(k). + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The MILU(k) factorization is computed if ialg = 2 (= mld_milu_n_); + ! the ILU(k) factorization otherwise. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see mld_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by mld_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see mld_fact_bld), then b does not contain any row. + ! d - real(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! laspk - real(psb_spk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uaspk - real(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uaspk, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in laspk. + ! l2 - integer, output + ! The number of nonzero entries in uaspk. + ! info - integer, output. + ! Error code. + ! + subroutine mld_siluk_factint(fill_in,ialg,m,a,b,& + & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + + use psb_base_mod + + implicit none + + ! Arguments + integer, intent(in) :: fill_in, ialg + type(psb_sspmat_type), intent(in) :: a,b + integer, intent(inout) :: m,l1,l2,info + integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) + real(psb_spk_), allocatable, intent(inout) :: laspk(:),uaspk(:) + real(psb_spk_), intent(inout) :: d(:) + + ! Local variables + integer :: ma,mb,i, ktrw,err_act,nidx + integer, allocatable :: uplevs(:), rowlevs(:),idxs(:) + real(psb_spk_), allocatable :: row(:) + type(psb_int_heap) :: heap + type(psb_sspmat_type) :: trw + character(len=20), parameter :: name='mld_siluk_factint' + character(len=20) :: ch_err + + if (psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + select case(ialg) + case(mld_ilu_n_,mld_milu_n_) + ! Ok + case default + info=35 + call psb_errpush(info,name,i_err=(/2,ialg,0,0,0/)) + goto 9999 + end select + if (fill_in < 0) then + info=35 + call psb_errpush(info,name,i_err=(/1,fill_in,0,0,0/)) + goto 9999 + end if + + ma = a%m + mb = b%m + m = ma+mb + + ! + ! Allocate a temporary buffer for the iluk_copyin function + ! + call psb_sp_all(0,0,trw,1,info) + if (info==0) call psb_ensure_size(m+1,lia2,info) + if (info==0) call psb_ensure_size(m+1,uia2,info) + + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lia2(1) = 1 + uia2(1) = 1 + + ! + ! Allocate memory to hold the entries of a row and the corresponding + ! fill levels + ! + allocate(uplevs(size(uaspk)),rowlevs(m),row(m),stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + uplevs(:) = m+1 + row(:) = szero + rowlevs(:) = -(m+1) + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the iluk_copyin routine, and updated during the elimination, in + ! the iluk_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = szero + if (i<=ma) then + ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! + call iluk_copyin(i,ma,a,1,m,row,rowlevs,heap,ktrw,trw,info) + else + ! + ! Copy into trw the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row) + ! + call iluk_copyin(i-ma,mb,b,1,m,row,rowlevs,heap,ktrw,trw,info) + endif + + ! Do an elimination step on the current row. It turns out we only + ! need to keep track of fill levels for the upper triangle, hence we + ! do not have a lowlevs variable. + ! + if (info == 0) call iluk_fact(fill_in,i,row,rowlevs,heap,& + & d,uia1,uia2,uaspk,uplevs,nidx,idxs,info) + ! + ! Copy the row into laspk/d(i)/uaspk + ! + if (info == 0) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& + & l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,uplevs,info) + if (info /= 0) then + info=4001 + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + end do + + ! + ! And we're done, so deallocate the memory + ! + deallocate(uplevs,rowlevs,row,stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == 0) call psb_sp_free(trw,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mld_siluk_factint + + ! + ! Subroutine: iluk_copyin + ! Version: real + ! Note: internal subroutine of mld_siluk_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the sparse matrix + ! structure a, into the array row and stores into a heap the column indices of + ! the nonzero entries of the copied row. The output array row is such that it + ! contains a full row of A, i.e. it contains also the zero entries of the row. + ! This is useful for the elimination step performed by iluk_fact after the call + ! to iluk_copyin (see mld_iluk_factint). + ! The routine also sets to zero the entries of the array rowlevs corresponding + ! to the nonzero entries of the copied row (see the description of the arguments + ! below). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilu_copyin. + ! + ! This routine is used by mld_siluk_factint in the computation of the + ! ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! row - real(psb_spk_), dimension(:), input/output. + ! In input it is the null vector (see mld_iluk_factint and + ! iluk_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /=0, for + ! future use in iluk_fact. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_sspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(inout) :: trw + integer, intent(in) :: i,m,jmin,jmax + integer, intent(inout) :: ktrw,info + integer, intent(inout) :: rowlevs(:) + real(psb_spk_), intent(inout) :: row(:) + type(psb_int_heap), intent(inout) :: heap + + ! Local variables + integer :: k,j,irb,err_act + integer, parameter :: nrb=16 + character(len=20), parameter :: name='iluk_copyin' + character(len=20) :: ch_err + + if (psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + call psb_init_heap(heap,info) + + if (psb_toupper(a%fida)=='CSR') then + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = a%ia2(i), a%ia2(i+1) - 1 + k = a%ia1(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = a%aspk(j) + rowlevs(k) = 0 + call psb_insert_heap(k,heap,info) + end if + end do + + else + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to iluk_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb==1)) then + irb = min(m-i+1,nrb) + call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + if (info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%aspk(ktrw) + rowlevs(k) = 0 + call psb_insert_heap(k,heap,info) + end if + ktrw = ktrw + 1 + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine iluk_copyin + + ! + ! Subroutine: iluk_fact + ! Version: real + ! Note: internal subroutine of mld_siluk_fact + ! + ! This routine does an elimination step of the ILU(k) factorization on a + ! single matrix row (see the calling routine mld_iluk_factint). + ! + ! This step is also the base for a MILU(k) elimination step on the row (see + ! iluk_copyout). This routine is used by mld_siluk_factint in the computation + ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! NOTE: it turns out we only need to keep track of the fill levels for + ! the upper triangle. + ! + ! + ! Arguments + ! fill_in - integer, input. + ! The fill-in level k in ILU(k). + ! i - integer, input. + ! The local index of the row to which the factorization is + ! applied. + ! row - real(psb_spk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = 0 if the k-th entry of the row is + ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output + ! rowlevs(k) contains the fill kevel of the k-th entry of + ! the row after the current elimination step; rowlevs(k) = -(m+1) + ! means that the k-th row entry is zero throughout the elimination + ! step. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the indices concerning the transformed row. + ! d - real(psb_spk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see iluk_copyout). + ! uia1 - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uaspk row by row (see + ! iluk_copyout, called by mld_siluk_factint), according to the CSR + ! storage format. + ! uia2 - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uaspk row by row + ! (see iluk_copyout, called by mld_siluk_factint), according to + ! the CSR storage format. + ! uaspk - real(psb_spk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! uplevs - integer, dimension(:), input. + ! The fill levels of the nonzero entries in the part of the + ! U factor above the current row. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine iluk_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine iluk_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by this routine. + ! + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uia1,uia2,uaspk,uplevs,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_int_heap), intent(inout) :: heap + integer, intent(in) :: i, fill_in + integer, intent(inout) :: nidx,info + integer, intent(inout) :: rowlevs(:) + integer, allocatable, intent(inout) :: idxs(:) + integer, intent(inout) :: uia1(:),uia2(:),uplevs(:) + real(psb_spk_), intent(inout) :: row(:), uaspk(:),d(:) + + ! Local variables + integer :: k,j,lrwk,jj,lastk, iret + real(psb_spk_) :: rwk + + info = 0 + if (.not.allocated(idxs)) then + allocate(idxs(200),stat=info) + if (info /= 0) return + endif + nidx = 0 + lastk = -1 + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call psb_heap_get_first(k,heap,iret) + if (iret < 0) return + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= 0) return + end if + idxs(nidx) = k + + if ((row(k) /= szero).and.(rowlevs(k) <= fill_in).and.(ki) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uaspk) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max((l2/i)*m,int(1.2*l2),l2+100) + call psb_realloc(isz,uaspk,info) + if (info == 0) call psb_realloc(isz,uia1,info) + if (info == 0) call psb_realloc(isz,uplevs,info,pad=(m+1)) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uia1(l2) = j + uaspk(l2) = row(j) + uplevs(l2) = rowlevs(j) + else if (ialg == mld_milu_n_) then + ! + ! MILU(k): add discarded entries to the diagonal one + ! + d(i) = d(i) + row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = szero + rowlevs(j) = -(m+1) + end if + end do + + ! + ! Store the pointers to the first non occupied entry of in + ! laspk and uaspk + ! + lia2(i+1) = l1 + 1 + uia2(i+1) = l2 + 1 + + ! + ! Check the pivot size + ! + if (abs(d(i)) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = 2 + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = sone/d(i) + end if + + ! + ! Scale the upper part + ! + do j=uia2(i), uia2(i+1)-1 + uaspk(j) = d(i)*uaspk(j) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + + end subroutine iluk_copyout + + +end subroutine mld_siluk_fact diff --git a/mlprec/mld_silut_fact.f90 b/mlprec/mld_silut_fact.f90 new file mode 100644 index 00000000..b39e3300 --- /dev/null +++ b/mlprec/mld_silut_fact.f90 @@ -0,0 +1,1158 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_silut_fact.f90 +! +! Subroutine: mld_silut_fact +! Version: real +! Contains: mld_silut_factint, ilut_copyin, ilut_fact, ilut_copyout +! +! This routine computes the ILU(k,t) factorization of the diagonal blocks of a +! distributed matrix. This factorization is used to build the 'base +! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz +! preconditioner) corresponding to a certain level of a multilevel preconditioner. +! +! Details on the above factorization can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in +! the description of the arguments below. The storage format for both the L and +! U factors is CSR. The diagonal of the U factor is stored separately (actually, +! the inverse of the diagonal entries is stored; this is then managed in the solve +! stage associated to the ILU(k,t) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in parameter k in ILU(k,t). +! thres - integer, input. +! The threshold t, i.e. the drop tolerance, in ILU(k,t). +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see mld_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_sspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_sspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! d - real(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine mld_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_sspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see mld_fact_bld), then blck does not contain any row. +! +subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_silut_fact + + implicit none + + ! Arguments + integer, intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + real(psb_spk_), intent(inout) :: d(:) + type(psb_sspmat_type),intent(in), optional, target :: blck + + ! Local Variables + integer :: l1, l2, m, err_act + + type(psb_sspmat_type), pointer :: blck_ + character(len=20) :: name, ch_err + + name='mld_silut_fact' + info = 0 + call psb_erractionsave(err_act) + + if (fill_in < 0) then + info=35 + call psb_errpush(info,name,i_err=(/1,fill_in,0,0,0/)) + goto 9999 + end if + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_sp_all(0,0,blck_,1,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + + ! + ! Compute the ILU(k,t) factorization + ! + call mld_silut_factint(fill_in,thres,m,a,blck_,& + & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + if (info /= 0) then + info=4010 + ch_err='mld_silut_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + l%infoa(1) = l1 + l%fida = 'CSR' + l%descra = 'TLU' + u%infoa(1) = l2 + u%fida = 'CSR' + u%descra = 'TUU' + l%m = m + l%k = m + u%m = m + u%k = m + + ! + ! Nullify the pointer / deallocate the memory + ! + if (present(blck)) then + blck_ => null() + else + call psb_sp_free(blck_,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + ! + ! Subroutine: mld_silut_factint + ! Version: real + ! Note: internal subroutine of mld_silut_fact + ! + ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a + ! distributed matrix. This factorization is used to build the 'base + ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix to be factorized is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k,t) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in parameter k in ILU(k,t). + ! thres - integer, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see mld_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by mld_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see mld_fact_bld), then b does not contain any row. + ! d - real(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! laspk - real(psb_spk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uaspk - real(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uaspk, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in laspk. + ! l2 - integer, output + ! The number of nonzero entries in uaspk. + ! info - integer, output. + ! Error code. + ! + subroutine mld_silut_factint(fill_in,thres,m,a,b,& + & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + + use psb_base_mod + + implicit none + + ! Arguments + integer, intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + type(psb_sspmat_type), intent(in) :: a,b + integer, intent(inout) :: m,l1,l2,info + integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) + real(psb_spk_), allocatable, intent(inout) :: laspk(:),uaspk(:) + real(psb_spk_), intent(inout) :: d(:) + + ! Local Variables + integer :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb + real(psb_spk_) :: nrmi + integer, allocatable :: idxs(:) + real(psb_spk_), allocatable :: row(:) + type(psb_int_heap) :: heap + type(psb_sspmat_type) :: trw + character(len=20), parameter :: name='mld_silut_factint' + character(len=20) :: ch_err + + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + + + ma = a%m + mb = b%m + m = ma+mb + + ! + ! Allocate a temporary buffer for the ilut_copyin function + ! + call psb_sp_all(0,0,trw,1,info) + if (info==0) call psb_ensure_size(m+1,lia2,info) + if (info==0) call psb_ensure_size(m+1,uia2,info) + + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lia2(1) = 1 + uia2(1) = 1 + + ! + ! Allocate memory to hold the entries of a row + ! + allocate(row(m),stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + row(:) = szero + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the ilut_copyin function, and updated during the elimination, in + ! the ilut_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = szero + if (i<=ma) then + call ilut_copyin(i,ma,a,i,1,m,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) + else + call ilut_copyin(i-ma,mb,b,i,1,m,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) + endif + + ! + ! Do an elimination step on current row + ! + if (info == 0) call ilut_fact(thres,i,nrmi,row,heap,& + & d,uia1,uia2,uaspk,nidx,idxs,info) + ! + ! Copy the row into laspk/d(i)/uaspk + ! + if (info == 0) call ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row,nidx,idxs,& + & l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,info) + + if (info /= 0) then + info=4001 + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + + end do + + ! + ! And we're done, so deallocate the memory + ! + deallocate(row,idxs,stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == 0) call psb_sp_free(trw,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mld_silut_factint + + ! + ! Subroutine: ilut_copyin + ! Version: real + ! Note: internal subroutine of mld_silut_fact + ! + ! This routine performs the following tasks: + ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, + ! into the array row; + ! - storing into a heap the column indices of the nonzero entries of the copied + ! row; + ! - computing the column index of the first entry with maximum absolute value + ! in the part of the row belonging to the upper triangle; + ! - computing the 2-norm of the row. + ! The output array row is such that it contains a full row of A, i.e. it contains + ! also the zero entries of the row. This is useful for the elimination step + ! performed by ilut_fact after the call to ilut_copyin (see mld_ilut_factint). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilut_copyin. + ! + ! This routine is used by mld_silut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the row to be + ! copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! nlw - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the lower triangle of the matrix. + ! nup - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the upper triangle of the matrix. + ! jmaxup - integer, output. + ! The column index of the first entry with maximum absolute + ! value in the part of the row belonging to the upper triangle + ! nrmi - real(psb_spk_), output. + ! The 2-norm of the current row. + ! row - real(psb_spk_), dimension(:), input/output. + ! In input it is the null vector (see mld_ilut_factint and + ! ilut_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /=0, for + ! future use in ilut_fact. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_sspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) + use psb_base_mod + implicit none + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(inout) :: trw + integer, intent(in) :: i, m,jmin,jmax,jd + integer, intent(inout) :: ktrw,nlw,nup,jmaxup,info + real(psb_spk_), intent(inout) :: nrmi,row(:) + type(psb_int_heap), intent(inout) :: heap + + integer :: k,j,irb,kin,nz + integer, parameter :: nrb=16 + real(psb_spk_) :: dmaxup + real(psb_spk_), external :: snrm2 + character(len=20), parameter :: name='mld_silut_factint' + + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + + call psb_init_heap(heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = szero + nrmi = szero + + if (psb_toupper(a%fida)=='CSR') then + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = a%ia2(i), a%ia2(i+1) - 1 + k = a%ia1(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = a%aspk(j) + call psb_insert_heap(k,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end if + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end do + nz = a%ia2(i+1) - a%ia2(i) + nrmi = snrm2(nz,a%aspk(a%ia2(i)),ione) + else + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to ilut_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb==1)) then + irb = min(m-i+1,nrb) + call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_sp_getblk') + goto 9999 + end if + ktrw=1 + end if + + kin = ktrw + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%aspk(ktrw) + call psb_insert_heap(k,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end if + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + ktrw = ktrw + 1 + enddo + nz = ktrw - kin + nrmi = snrm2(nz,trw%aspk(kin),ione) + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine ilut_copyin + + ! + ! Subroutine: ilut_fact + ! Version: real + ! Note: internal subroutine of mld_silut_fact + ! + ! This routine does an elimination step of the ILU(k,t) factorization on a single + ! matrix row (see the calling routine mld_ilut_factint). Actually, only the dropping + ! rule based on the threshold is applied here. The dropping rule based on the + ! fill-in is applied by ilut_copyout. + ! + ! The routine is used by mld_silut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments + ! thres - integer, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! i - integer, input. + ! The local index of the row to which the factorization is applied. + ! nrmi - real(psb_spk_), input. + ! The 2-norm of the row to which the elimination step has to be + ! applied. + ! row - real(psb_spk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the previous indices plus the ones corresponding to transformed + ! entries in the 'upper part' that have not been dropped. + ! d - real(psb_spk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see ilut_copyout). + ! uia1 - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uaspk row by row (see + ! ilut_copyout, called by mld_silut_factint), according to the CSR + ! storage format. + ! uia2 - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uaspk row by row + ! (see ilut_copyout, called by mld_silut_factint), according to + ! the CSR storage format. + ! uaspk - real(psb_spk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine ilut_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine ilut_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by this routine. + ! + subroutine ilut_fact(thres,i,nrmi,row,heap,d,uia1,uia2,uaspk,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_int_heap), intent(inout) :: heap + integer, intent(in) :: i + integer, intent(inout) :: nidx,info + real(psb_spk_), intent(in) :: thres,nrmi + integer, allocatable, intent(inout) :: idxs(:) + integer, intent(inout) :: uia1(:),uia2(:) + real(psb_spk_), intent(inout) :: row(:), uaspk(:),d(:) + + ! Local Variables + integer :: k,j,jj,lastk,iret + real(psb_spk_) :: rwk + + info = 0 + call psb_ensure_size(200,idxs,info) + if (info /= 0) return + nidx = 0 + lastk = -1 + ! + ! Do while there are indices to be processed + ! + do + + call psb_heap_get_first(k,heap,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + lowert: if (k nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call psb_insert_heap(witem,widx,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + ! + ! Now we have to take out the first nlw+fill_in entries + ! + if (nz <= nlw+fill_in) then + ! + ! Just copy everything from xw, and it is already ordered + ! + else + nz = nlw+fill_in + do k=1,nz + call psb_heap_get_first(witem,widx,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_heap_get_first') + goto 9999 + end if + + xw(k) = witem + xwid(k) = widx + end do + end if + + ! + ! Now put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the lower part of the row + ! + do k=1,nz + l1 = l1 + 1 + if (size(laspk) < l1) then + ! + ! Figure out a good reallocation size! + ! + isz = (max((l1/i)*m,int(1.2*l1),l1+100)) + call psb_realloc(isz,laspk,info) + if (info == 0) call psb_realloc(isz,lia1,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + lia1(l1) = xwid(k) + laspk(l1) = xw(indx(k)) + end do + + ! + ! Make sure idxp points to the diagonal entry + ! + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + if (idxp > size(idxs)) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else + if (idxs(idxp) > i) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else if (idxs(idxp) /= i) then +!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' + else + ! + ! Copy the diagonal entry + ! + widx = idxs(idxp) + witem = row(widx) + d(i) = witem + if (abs(d(i)) < epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = 2 + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = sone/d(i) + end if + end if + end if + + ! + ! Now the upper part + ! + + call psb_init_heap(heap,info,dir=psb_asort_down_) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + nz = 0 + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx <= i) then +!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then +!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call psb_insert_heap(witem,widx,heap,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call psb_heap_get_first(witem,widx,heap,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i (ilev-1). +! baseprecv(ilev)%av(mld_sm_pr_t_) - The smoothed prolongator transpose. +! It maps vectors (ilev-1) ---> (ilev). +! baseprecv(ilev)%d - real(psb_spk_), dimension(:), allocatable. +! The diagonal entries of the U factor in the ILU +! factorization of A(ilev). +! baseprecv(ilev)%desc_data - type(psb_desc_type). +! The communication descriptor associated to the base +! preconditioner, i.e. to the sparse matrices needed +! to apply the base preconditioner at the current level. +! baseprecv(ilev)%desc_ac - type(psb_desc_type). +! The communication descriptor associated to the sparse +! matrix A(ilev), stored in baseprecv(ilev)%av(mld_ac_). +! baseprecv(ilev)%iprcparm - integer, dimension(:), allocatable. +! The integer parameters defining the base +! preconditioner K(ilev). +! baseprecv(ilev)%rprcparm - real(psb_spk_), dimension(:), allocatable. +! The real parameters defining the base preconditioner +! K(ilev). +! baseprecv(ilev)%perm - integer, dimension(:), allocatable. +! The row and column permutations applied to the local +! part of A(ilev) (defined only if baseprecv(ilev)% +! iprcparm(mld_sub_ren_)>0). +! baseprecv(ilev)%invperm - integer, dimension(:), allocatable. +! The inverse of the permutation stored in +! baseprecv(ilev)%perm. +! baseprecv(ilev)%mlia - integer, dimension(:), allocatable. +! The aggregation map (ilev-1) --> (ilev). +! In case of non-smoothed aggregation, it is used +! instead of mld_sm_pr_. +! baseprecv(ilev)%nlaggr - integer, dimension(:), allocatable. +! The number of aggregates (rows of A(ilev)) on the +! various processes. +! baseprecv(ilev)%base_a - type(psb_sspmat_type), pointer. +! Pointer (really a pointer!) to the base matrix of +! the current level, i.e. the local part of A(ilev); +! so we have a unified treatment of residuals. We +! need this to avoid passing explicitly the matrix +! A(ilev) to the routine which applies the +! preconditioner. +! baseprecv(ilev)%base_desc - type(psb_desc_type), pointer. +! Pointer to the communication descriptor associated +! to the sparse matrix pointed by base_a. +! baseprecv(ilev)%dorig - real(psb_spk_), dimension(:), allocatable. +! Diagonal entries of the matrix pointed by base_a. +! +! x - real(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - real(psb_spk_), input. +! The scalar beta. +! y - real(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! work - real(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +! Note that when the LU factorization of the matrix A(ilev) is computed instead of +! the ILU one, by using UMFPACK or SuperLU, the corresponding L and U factors +! are stored in data structures provided by UMFPACK or SuperLU and pointed by +! baseprecv(ilev)%iprcparm(mld_umf_ptr) or baseprecv(ilev)%iprcparm(mld_slu_ptr), +! respectively. +! +subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_smlprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: baseprecv(:) + real(psb_spk_),intent(in) :: alpha,beta + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: ictxt, np, me, err_act + integer :: debug_level, debug_unit + character(len=20) :: name + character :: trans_ + + name='mld_smlprec_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + trans_ = psb_toupper(trans) + + select case(baseprecv(2)%iprcparm(mld_ml_type_)) + + case(mld_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(4001,name,a_err='mld_no_ml_ in mlprc_aply?') + goto 9999 + + case(mld_add_ml_) + ! + ! Additive multilevel + ! + + call add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + + case(mld_mult_ml_) + ! + ! Multiplicative multilevel (multiplicative among the levels, additive inside + ! each level) + ! + ! Pre/post-smoothing versions. + ! Note that the transpose switches pre <-> post. + ! + + select case(baseprecv(2)%iprcparm(mld_smooth_pos_)) + + case(mld_post_smooth_) + + select case (trans_) + case('N') + call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + case('T','C') + call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid trans') + goto 9999 + end select + + case(mld_pre_smooth_) + + select case (trans_) + case('N') + call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + case('T','C') + call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + case default + info = 4001 + call psb_errpush(info,name,a_err='invalid trans') + goto 9999 + end select + + case(mld_twoside_smooth_) + + call mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info) + + case default + info = 4013 + call psb_errpush(info,name,a_err='invalid smooth_pos',& + & i_Err=(/baseprecv(2)%iprcparm(mld_smooth_pos_),0,0,0,0/)) + goto 9999 + + end select + + case default + info = 4013 + call psb_errpush(info,name,a_err='invalid mltype',& + & i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + ! + ! Subroutine: add_ml_aply + ! Version: real + ! Note: internal subroutine of mld_smlprec_aply. + ! + ! This routine computes + ! + ! Y = beta*Y + alpha*op(M^(-1))*X, + ! where + ! - M is an additive multilevel domain decomposition (Schwarz) preconditioner + ! associated to a certain matrix A and stored in the array baseprecv, + ! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans, + ! - X and Y are vectors, + ! - alpha and beta are scalars. + ! + ! The preconditioner M is additive both through the levels and inside each + ! level. + ! + ! For each level we have as many submatrices as processes (except for the coarsest + ! level where we might have a replicated index space) and each process takes care + ! of one submatrix. + ! + ! The multilevel preconditioner M is regarded as an array of 'base preconditioners', + ! each representing the part of the preconditioner associated to a certain level. + ! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev) + ! and is associated to a matrix A(ilev), obtained by 'tranferring' the original + ! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed + ! aggregation. + ! + ! The levels are numbered in increasing order starting from the finest one, i.e. + ! level 1 is the finest level and A(1) is the matrix A. + ! + ! For details on the additive multilevel Schwarz preconditioner see the + ! Algorithm 3.1.1 in the book: + ! B.F. Smith, P.E. Bjorstad & W.D. Gropp, + ! Domain decomposition: parallel multilevel methods for elliptic partial + ! differential equations, Cambridge University Press, 1996. + ! + ! For a description of the arguments see mld_smlprec_aply. + ! + ! A sketch of the algorithm implemented in this routine is provided below + ! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to + ! level ilev-1, while AV(ilev; sm_pr_t_) denotes its transpose, i.e. the + ! corresponding restriction operator from level ilev-1 to level ilev). + ! + ! 1. ! Apply the base preconditioner at level 1. + ! ! The sum over the subdomains is carried out in the + ! ! application of K(1). + ! X(1) = Xest + ! Y(1) = (K(1)^(-1))*X(1) + ! + ! 2. DO ilev=2,nlev + ! + ! ! Transfer X(ilev-1) to the next coarser level. + ! X(ilev) = AV(ilev; sm_pr_t_)*X(ilev-1) + ! + ! ! Apply the base preconditioner at the current level. + ! ! The sum over the subdomains is carried out in the + ! ! application of K(ilev). + ! Y(ilev) = (K(ilev)^(-1))*X(ilev) + ! + ! ENDDO + ! + ! 3. DO ilev=nlev-1,1,-1 + ! + ! ! Transfer Y(ilev+1) to the next finer level. + ! Y(ilev) = AV(ilev+1; sm_pr_)*Y(ilev+1) + ! + ! ENDDO + ! + ! 4. Yext = beta*Yext + alpha*Y(1) + ! + subroutine add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: baseprecv(:) + real(psb_spk_),intent(in) :: alpha,beta + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + integer :: ictxt,np,me,i, nr2l,nc2l,err_act + integer :: debug_level, debug_unit + integer :: ismth, nlev, ilev, icm + character(len=20) :: name + + type psb_mlprec_wrk_type + real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type psb_mlprec_wrk_type + type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + + name='add_ml_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + nlev = size(baseprecv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! + ! STEP 1 + ! + ! Apply the base preconditioner at the finest level + ! + allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)), stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/size(x)+size(y),0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + mlprec_wrk(1)%x2l(:) = x(:) + mlprec_wrk(1)%y2l(:) = szero + + call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,& + & baseprecv(1)%base_desc,trans,work,info) + if (info /=0) then + call psb_errpush(4010,name,a_err='baseprec_aply') + goto 9999 + end if + ! + ! STEP 2 + ! + ! For each level except the finest one ... + ! + do ilev = 2, nlev + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + allocate(mlprec_wrk(ilev)%x2l(nc2l),mlprec_wrk(ilev)%y2l(nc2l),& + & stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + + ! Apply prolongator transpose, i.e. restriction + call psb_forward_map(sone,mlprec_wrk(ilev-1)%x2l,& + & szero,mlprec_wrk(ilev)%x2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + + if (icm == mld_repl_mat_) then + call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) + else if (icm /= mld_distr_mat_) then + info = 4013 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',& + & i_Err=(/icm,0,0,0,0/)) + goto 9999 + endif + + ! + ! Apply the base preconditioner + ! + call mld_baseprec_aply(sone,baseprecv(ilev),& + & mlprec_wrk(ilev)%x2l,szero,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev)%base_desc, trans,work,info) + + enddo + + ! + ! STEP 3 + ! + ! For each level except the finest one ... + ! + do ilev =nlev,2,-1 + + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + + ! + ! Apply prolongator + ! + call psb_backward_map(sone,mlprec_wrk(ilev)%y2l,& + & sone,mlprec_wrk(ilev-1)%y2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during prolongation') + goto 9999 + end if + end do + + ! + ! STEP 4 + ! + ! Compute the output vector Y + ! + call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,sone,y,baseprecv(1)%base_desc,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error on final update') + goto 9999 + end if + + deallocate(mlprec_wrk,stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine add_ml_aply + ! + ! Subroutine: mlt_pre_ml_aply + ! Version: real + ! Note: internal subroutine of mld_smlprec_aply. + ! + ! This routine computes + ! + ! Y = beta*Y + alpha*op(M^(-1))*X, + ! where + ! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner + ! associated to a certain matrix A and stored in the array baseprecv, + ! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans, + ! - X and Y are vectors, + ! - alpha and beta are scalars. + ! + ! The preconditioner M is hybrid in the sense that it is multiplicative through the + ! levels and additive inside a level; pre-smoothing only is applied at each level. + ! + ! For each level we have as many submatrices as processes (except for the coarsest + ! level where we might have a replicated index space) and each process takes care + ! of one submatrix. + ! + ! The multilevel preconditioner M is regarded as an array of 'base preconditioners', + ! each representing the part of the preconditioner associated to a certain level. + ! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev) + ! and is associated to a matrix A(ilev), obtained by 'tranferring' the original + ! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed + ! aggregation. + ! + ! The levels are numbered in increasing order starting from the finest one, i.e. + ! level 1 is the finest level and A(1) is the matrix A. + ! + ! For details on the pre-smoothed hybrid multiplicative multilevel Schwarz + ! preconditioner, see the Algorithm 3.2.1 in the book: + ! B.F. Smith, P.E. Bjorstad & W.D. Gropp, + ! Domain decomposition: parallel multilevel methods for elliptic partial + ! differential equations, Cambridge University Press, 1996. + ! + ! For a description of the arguments see mld_smlprec_aply. + ! + ! A sketch of the algorithm implemented in this routine is provided below + ! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to + ! level ilev-1, while AV(ilev; sm_pr_t_) denotes its transpose, i.e. the + ! corresponding restriction operator from level ilev-1 to level ilev). + ! + ! 1. X(1) = Xext + ! + ! 2. ! Apply the base preconditioner at the finest level. + ! Y(1) = (K(1)^(-1))*X(1) + ! + ! 3. ! Compute the residual at the finest level. + ! TX(1) = X(1) - A(1)*Y(1) + ! + ! 4. DO ilev=2, nlev + ! + ! ! Transfer the residual to the current (coarser) level. + ! X(ilev) = AV(ilev; sm_pr_t_)*TX(ilev-1) + ! + ! ! Apply the base preconditioner at the current level. + ! ! The sum over the subdomains is carried out in the + ! ! application of K(ilev). + ! Y(ilev) = (K(ilev)^(-1))*X(ilev) + ! + ! ! Compute the residual at the current level (except at + ! ! the coarsest level). + ! IF (ilev < nlev) + ! TX(ilev) = (X(ilev)-A(ilev)*Y(ilev)) + ! + ! ENDDO + ! + ! 5. DO ilev=nlev-1,1,-1 + ! + ! ! Transfer Y(ilev+1) to the next finer level + ! Y(ilev) = Y(ilev) + AV(ilev+1; sm_pr_)*Y(ilev+1) + ! + ! ENDDO + ! + ! 6. Yext = beta*Yext + alpha*Y(1) + ! + ! + subroutine mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: baseprecv(:) + real(psb_spk_),intent(in) :: alpha,beta + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + integer :: ictxt,np,me,i, nr2l,nc2l,err_act + integer :: debug_level, debug_unit + integer :: ismth, nlev, ilev, icm + character(len=20) :: name + + type psb_mlprec_wrk_type + real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type psb_mlprec_wrk_type + type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + + name='mlt_pre_ml_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + nlev = size(baseprecv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! + ! STEP 1 + ! + ! Copy the input vector X + ! + n_col = psb_cd_get_local_cols(desc_data) + nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc) + + allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), & + & mlprec_wrk(1)%tx(nc2l), stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + mlprec_wrk(1)%x2l(:) = x + ! + ! STEP 2 + ! + ! Apply the base preconditioner at the finest level + ! + call mld_baseprec_aply(sone,baseprecv(1),mlprec_wrk(1)%x2l,& + & szero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,& + & trans,work,info) + if (info /=0) then + call psb_errpush(4010,name,a_err=' baseprec_aply') + goto 9999 + end if + + ! + ! STEP 3 + ! + ! Compute the residual at the finest level + ! + mlprec_wrk(1)%tx = mlprec_wrk(1)%x2l + + call psb_spmm(-sone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,& + & sone,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,& + & work=work,trans=trans) + if (info /=0) then + call psb_errpush(4001,name,a_err=' fine level residual') + goto 9999 + end if + + ! + ! STEP 4 + ! + ! For each level but the finest one ... + ! + do ilev = 2, nlev + + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + + allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),& + & mlprec_wrk(ilev)%x2l(nc2l), stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + ! Apply prolongator transpose, i.e. restriction + call psb_forward_map(sone,mlprec_wrk(ilev-1)%tx,& + & szero,mlprec_wrk(ilev)%x2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + if (icm ==mld_repl_mat_) then + call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) + else if (icm /= mld_distr_mat_) then + info = 4013 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',& + & i_Err=(/icm,0,0,0,0/)) + goto 9999 + endif + + ! + ! Apply the base preconditioner + ! + call mld_baseprec_aply(sone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,& + & szero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info) + + ! + ! Compute the residual (at all levels but the coarsest one) + ! + if (ilev < nlev) then + mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l + if (info == 0) call psb_spmm(-sone,baseprecv(ilev)%base_a,& + & mlprec_wrk(ilev)%y2l,sone,mlprec_wrk(ilev)%tx,& + & baseprecv(ilev)%base_desc,info,work=work,trans=trans) + endif + if (info /=0) then + call psb_errpush(4001,name,a_err='Error on up sweep residual') + goto 9999 + end if + enddo + + ! + ! STEP 5 + ! + ! For each level but the coarsest one ... + ! + do ilev = nlev-1, 1, -1 + + ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_) + n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + + ! + ! Apply prolongator + ! + call psb_backward_map(sone,mlprec_wrk(ilev+1)%y2l,& + & sone,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev+1)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during prolongation') + goto 9999 + end if + enddo + + ! + ! STEP 6 + ! + ! Compute the output vector Y + ! + call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,& + & baseprecv(1)%base_desc,info) + if (info /=0) then + call psb_errpush(4001,name,a_err='Error on final update') + goto 9999 + end if + + deallocate(mlprec_wrk,stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mlt_pre_ml_aply + ! + ! Subroutine: mlt_post_ml_aply + ! Version: real + ! Note: internal subroutine of mld_smlprec_aply. + ! + ! This routine computes + ! + ! Y = beta*Y + alpha*op(M^(-1))*X, + ! where + ! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner + ! associated to a certain matrix A and stored in the array baseprecv, + ! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans, + ! - X and Y are vectors, + ! - alpha and beta are scalars. + ! + ! The preconditioner M is hybrid in the sense that it is multiplicative through the + ! levels and additive inside a level; post-smoothing only is applied at each level. + ! + ! For each level we have as many submatrices as processes (except for the coarsest + ! level where we might have a replicated index space) and each process takes care + ! of one submatrix. + ! + ! The multilevel preconditioner M is regarded as an array of 'base preconditioners', + ! each representing the part of the preconditioner associated to a certain level. + ! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev) + ! and is associated to a matrix A(ilev), obtained by 'tranferring' the original + ! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed + ! aggregation. + ! + ! The levels are numbered in increasing order starting from the finest one, i.e. + ! level 1 is the finest level and A(1) is the matrix A. + ! + ! For details on hybrid multiplicative multilevel Schwarz preconditioners, see + ! B.F. Smith, P.E. Bjorstad & W.D. Gropp, + ! Domain decomposition: parallel multilevel methods for elliptic partial + ! differential equations, Cambridge University Press, 1996. + ! + ! For a description of the arguments see mld_smlprec_aply. + ! + ! A sketch of the algorithm implemented in this routine is provided below. + ! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to + ! level ilev-1, while AV(ilev; sm_pr_t_) denotes its transpose, i.e. the + ! corresponding restriction operator from level ilev-1 to level ilev). + ! + ! 1. X(1) = Xext + ! + ! 2. DO ilev=2, nlev + ! + ! ! Transfer X(ilev-1) to the next coarser level. + ! X(ilev) = AV(ilev; sm_pr_t_)*X(ilev-1) + ! + ! ENDDO + ! + ! 3.! Apply the preconditioner at the coarsest level. + ! Y(nlev) = (K(nlev)^(-1))*X(nlev) + ! + ! 4. DO ilev=nlev-1,1,-1 + ! + ! ! Transfer Y(ilev+1) to the next finer level. + ! Y(ilev) = AV(ilev+1; sm_pr_)*Y(ilev+1) + ! + ! ! Compute the residual at the current level and apply to it the + ! ! base preconditioner. The sum over the subdomains is carried out + ! ! in the application of K(ilev). + ! Y(ilev) = Y(ilev) + (K(ilev)^(-1))*(X(ilev)-A(ilev)*Y(ilev)) + ! + ! ENDDO + ! + ! 5. Yext = beta*Yext + alpha*Y(1) + ! + ! + subroutine mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: baseprecv(:) + real(psb_spk_),intent(in) :: alpha,beta + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + integer :: ictxt,np,me,i, nr2l,nc2l,err_act + integer :: debug_level, debug_unit + integer :: ismth, nlev, ilev, icm + character(len=20) :: name + + type psb_mlprec_wrk_type + real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type psb_mlprec_wrk_type + type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + + name='mlt_post_ml_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + nlev = size(baseprecv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! + ! STEP 1 + ! + ! Copy the input vector X + ! + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' desc_data status',allocated(desc_data%matrix_data) + + n_col = psb_cd_get_local_cols(desc_data) + nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc) + + allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), & + & mlprec_wrk(1)%tx(nc2l), stat=info) + + call psb_geaxpby(sone,x,szero,mlprec_wrk(1)%tx,& + & baseprecv(1)%base_desc,info) + call psb_geaxpby(sone,x,szero,mlprec_wrk(1)%x2l,& + & baseprecv(1)%base_desc,info) + + ! + ! STEP 2 + ! + ! For each level but the finest one ... + ! + do ilev=2, nlev + + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name), & + & ' starting up sweep ',& + & ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,& + & nc2l, nr2l,ismth + + allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),& + & mlprec_wrk(ilev)%x2l(nc2l), stat=info) + + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + ! Apply prolongator transpose, i.e. restriction + call psb_forward_map(sone,mlprec_wrk(ilev-1)%x2l,& + & szero,mlprec_wrk(ilev)%x2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + if (icm == mld_repl_mat_) Then + call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) + else if (icm /= mld_distr_mat_) Then + info = 4013 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',& + & i_Err=(/icm,0,0,0,0/)) + goto 9999 + endif + + ! + ! update x2l + ! + call psb_geaxpby(sone,mlprec_wrk(ilev)%x2l,szero,mlprec_wrk(ilev)%tx,& + & baseprecv(ilev)%base_desc,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error in update') + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done up sweep ', ilev + + enddo + + ! + ! STEP 3 + ! + ! Apply the base preconditioner at the coarsest level + ! + call mld_baseprec_aply(sone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, & + & szero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%base_desc,trans,work,info) + + if (info /=0) then + call psb_errpush(4010,name,a_err='baseprec_aply') + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) write(debug_unit,*) & + & me,' ',trim(name), ' done baseprec_aply ', nlev + + ! + ! STEP 4 + ! + ! For each level but the coarsest one ... + ! + do ilev=nlev-1, 1, -1 + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' starting down sweep',ilev + + ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_) + n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + + ! + ! Apply prolongator + ! + call psb_backward_map(sone,mlprec_wrk(ilev+1)%y2l,& + & szero,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev+1)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during prolongation') + goto 9999 + end if + + ! + ! Compute the residual + ! + call psb_spmm(-sone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& + & sone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,& + & work=work,trans=trans) + + ! + ! Apply the base preconditioner + ! + if (info == 0) call mld_baseprec_aply(sone,baseprecv(ilev),mlprec_wrk(ilev)%tx,& + & sone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info) + if (info /=0) then + call psb_errpush(4001,name,a_err=' spmm/baseprec_aply') + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done down sweep',ilev + enddo + + ! + ! STEP 5 + ! + ! Compute the output vector Y + ! + call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info) + + if (info /=0) then + call psb_errpush(4001,name,a_err=' Final update') + goto 9999 + end if + + + + deallocate(mlprec_wrk,stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mlt_post_ml_aply + ! + ! Subroutine: mlt_twoside_ml_aply + ! Version: real + ! Note: internal subroutine of mld_smlprec_aply. + ! + ! This routine computes + ! + ! Y = beta*Y + alpha*op(M^(-1))*X, + ! where + ! - M is a symmetrized hybrid multilevel domain decomposition (Schwarz) + ! preconditioner associated to a certain matrix A and stored in the array + ! baseprecv, + ! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans, + ! - X and Y are vectors, + ! - alpha and beta are scalars. + ! + ! The preconditioner M is hybrid in the sense that it is multiplicative through + ! the levels and additive inside a level; it is symmetrized since pre-smoothing + ! and post-smoothing are applied at each level. + ! + ! For each level we have as many submatrices as processes (except for the coarsest + ! level where we might have a replicated index space) and each process takes care + ! of one submatrix. + ! + ! The multilevel preconditioner M is regarded as an array of 'base preconditioners', + ! each representing the part of the preconditioner associated to a certain level. + ! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev) + ! and is associated to a matrix A(ilev), obtained by 'tranferring' the original + ! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed + ! aggregation. + ! + ! The levels are numbered in increasing order starting from the finest one, i.e. + ! level 1 is the finest level and A(1) is the matrix A. + ! + ! For details on the symmetrized hybrid multiplicative multilevel Schwarz + ! preconditioner, see the Algorithm 3.2.2 of the book: + ! B.F. Smith, P.E. Bjorstad & W.D. Gropp, + ! Domain decomposition: parallel multilevel methods for elliptic partial + ! differential equations, Cambridge University Press, 1996. + ! + ! For a description of the arguments see mld_smlprec_aply. + ! + ! A sketch of the algorithm implemented in this routine is provided below. + ! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to + ! level ilev-1, while AV(ilev; sm_pr_t_) denotes its transpose, i.e. the + ! corresponding restriction operator from level ilev-1 to level ilev). + ! + ! 1. X(1) = Xext + ! + ! 2. ! Apply the base peconditioner at the finest level + ! Y(1) = (K(1)^(-1))*X(1) + ! + ! 3. ! Compute the residual at the finest level + ! TX(1) = X(1) - A(1)*Y(1) + ! + ! 4. DO ilev=2, nlev + ! + ! ! Transfer the residual to the current (coarser) level + ! X(ilev) = AV(ilev; sm_pr_t)*TX(ilev-1) + ! + ! ! Apply the base preconditioner at the current level. + ! ! The sum over the subdomains is carried out in the + ! ! application of K(ilev) + ! Y(ilev) = (K(ilev)^(-1))*X(ilev) + ! + ! ! Compute the residual at the current level + ! TX(ilev) = (X(ilev)-A(ilev)*Y(ilev)) + ! + ! ENDDO + ! + ! 5. DO ilev=NLEV-1,1,-1 + ! + ! ! Transfer Y(ilev+1) to the next finer level + ! Y(ilev) = Y(ilev) + AV(ilev+1; sm_pr_)*Y(ilev+1) + ! + ! ! Compute the residual at the current level and apply to it the + ! ! base preconditioner. The sum over the subdomains is carried out + ! ! in the application of K(ilev) + ! Y(ilev) = Y(ilev) + (K(ilev)**(-1))*(X(ilev)-A(ilev)*Y(ilev)) + ! + ! ENDDO + ! + ! 6. Yext = beta*Yext + alpha*Y(1) + ! + subroutine mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: baseprecv(:) + real(psb_spk_),intent(in) :: alpha,beta + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + integer :: ictxt,np,me,i, nr2l,nc2l,err_act + integer :: debug_level, debug_unit + integer :: ismth, nlev, ilev, icm + character(len=20) :: name + + type psb_mlprec_wrk_type + real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type psb_mlprec_wrk_type + type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + + name='mlt_twoside_ml_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(baseprecv) + + nlev = size(baseprecv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! STEP 1 + ! + ! Copy the input vector X + ! + n_col = psb_cd_get_local_cols(desc_data) + nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc) + + allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), & + & mlprec_wrk(1)%ty(nc2l), mlprec_wrk(1)%tx(nc2l), stat=info) + + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + call psb_geaxpby(sone,x,szero,mlprec_wrk(1)%x2l,& + & baseprecv(1)%base_desc,info) + call psb_geaxpby(sone,x,szero,mlprec_wrk(1)%tx,& + & baseprecv(1)%base_desc,info) + + ! + ! STEP 2 + ! + ! Apply the base preconditioner at the finest level + ! + call mld_baseprec_aply(sone,baseprecv(1),mlprec_wrk(1)%x2l,& + & szero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,& + & trans,work,info) + ! + ! STEP 3 + ! + ! Compute the residual at the finest level + ! + mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l + if (info == 0) call psb_spmm(-sone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,& + & sone,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,& + & work=work,trans=trans) + if (info /=0) then + call psb_errpush(4010,name,a_err='Fine level baseprec/residual') + goto 9999 + end if + + ! + ! STEP 4 + ! + ! For each level but the finest one ... + ! + do ilev = 2, nlev + + n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc) + n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc) + nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc) + nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) + icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) + allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%ty(nc2l),& + & mlprec_wrk(ilev)%y2l(nc2l),mlprec_wrk(ilev)%x2l(nc2l), stat=info) + + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + ! Apply prolongator transpose, i.e. restriction + call psb_forward_map(sone,mlprec_wrk(ilev-1)%ty,& + & szero,mlprec_wrk(ilev)%x2l,& + & baseprecv(ilev)%map_desc,info,work=work) + + if (info /=0) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + if (icm == mld_repl_mat_) then + call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) + else if (icm /= mld_distr_mat_) then + info = 4013 + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',& + & i_Err=(/icm,0,0,0,0/)) + goto 9999 + endif + + call psb_geaxpby(sone,mlprec_wrk(ilev)%x2l,szero,mlprec_wrk(ilev)%tx,& + & baseprecv(ilev)%base_desc,info) + ! + ! Apply the base preconditioner + ! + if (info == 0) call mld_baseprec_aply(sone,baseprecv(ilev),& + & mlprec_wrk(ilev)%x2l,szero,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev)%base_desc,trans,work,info) + ! + ! Compute the residual (at all levels but the coarsest one) + ! + if(ilev < nlev) then + mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l + if (info == 0) call psb_spmm(-sone,baseprecv(ilev)%base_a,& + & mlprec_wrk(ilev)%y2l,sone,mlprec_wrk(ilev)%ty,& + & baseprecv(ilev)%base_desc,info,work=work,trans=trans) + endif + if (info /=0) then + call psb_errpush(4001,name,a_err='baseprec_aply/residual') + goto 9999 + end if + + enddo + + ! + ! STEP 5 + ! + ! For each level but the coarsest one ... + ! + do ilev=nlev-1, 1, -1 + + ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_) + n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) + + ! + ! Apply prolongator + ! + call psb_backward_map(sone,mlprec_wrk(ilev+1)%y2l,& + & sone,mlprec_wrk(ilev)%y2l,& + & baseprecv(ilev+1)%map_desc,info,work=work) + + if (info /=0 ) then + call psb_errpush(4001,name,a_err='Error during restriction') + goto 9999 + end if + + ! + ! Compute the residual + ! + call psb_spmm(-sone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& + & sone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,& + & work=work,trans=trans) + ! + ! Apply the base preconditioner + ! + if (info == 0) call mld_baseprec_aply(sone,baseprecv(ilev),mlprec_wrk(ilev)%tx,& + & sone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error: residual/baseprec_aply') + goto 9999 + end if + enddo + + ! + ! STEP 6 + ! + ! Compute the output vector Y + ! + call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,& + & baseprecv(1)%base_desc,info) + + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error final update') + goto 9999 + end if + + + + deallocate(mlprec_wrk,stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine mlt_twoside_ml_aply + +end subroutine mld_smlprec_aply + diff --git a/mlprec/mld_smlprec_bld.f90 b/mlprec/mld_smlprec_bld.f90 new file mode 100644 index 00000000..63185b66 --- /dev/null +++ b/mlprec/mld_smlprec_bld.f90 @@ -0,0 +1,180 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_smlprec_bld.f90 +! +! Subroutine: mld_smlprec_bld +! Version: real +! +! This routine builds the base preconditioner corresponding to the current +! level of the multilevel preconditioner. The routine first builds the +! (coarse) matrix associated to the current level from the (fine) matrix +! associated to the previous level, then builds the related base preconditioner. +! +! +! Arguments: +! a - type(psb_sspmat_type). +! The sparse matrix structure containing the local part of the +! matrix to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_sbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_smlprec_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_smlprec_bld + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_sbaseprc_type), intent(inout),target :: p + integer, intent(out) :: info + + ! Local variables + type(psb_desc_type) :: desc_ac + type(psb_sspmat_type) :: ac + character(len=20) :: name + integer :: ictxt, np, me, err_act + + name='mld_smlprec_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + info = 0 + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) + + if (.not.allocated(p%iprcparm)) then + info = 2222 + call psb_errpush(info,name) + goto 9999 + endif + call mld_check_def(p%iprcparm(mld_ml_type_),'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%iprcparm(mld_aggr_alg_),'Aggregation',& + & mld_dec_aggr_,is_legal_ml_aggr_alg) + call mld_check_def(p%iprcparm(mld_aggr_kind_),'Smoother',& + & mld_smooth_prol_,is_legal_ml_aggr_kind) + call mld_check_def(p%iprcparm(mld_coarse_mat_),'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + call mld_check_def(p%iprcparm(mld_smooth_pos_),'smooth_pos',& + & mld_pre_smooth_,is_legal_ml_smooth_pos) + + + select case(p%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_) + call mld_check_def(p%iprcparm(mld_sub_fill_in_),'Level',0,is_legal_ml_lev) + case(mld_ilu_t_) + call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',szero,is_legal_s_fact_thrs) + end select + call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',szero,is_legal_s_omega) + call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',& + & 1,is_legal_jac_sweeps) + + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + ! + ! Build the coarse-level matrix from the fine level one, starting from + ! the mapping defined by mld_aggrmap_bld and applying the aggregation + ! algorithm specified by p%iprcparm(mld_aggr_kind_) + ! + call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_aggrmat_asb') + goto 9999 + end if + + ! + ! Build the 'base preconditioner' corresponding to the coarse level + ! + call mld_baseprc_bld(ac,desc_ac,p,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_baseprc_bld') + goto 9999 + end if + + ! + ! We have used a separate ac because + ! 1. we want to reuse the same routines mld_ilu_bld, etc., + ! 2. we do NOT want to pass an argument twice to them (p%av(mld_ac_) and p), + ! as this would violate the Fortran standard. + ! Hence a separate AC and a TRANSFER function at the end. + ! + call psb_sp_transfer(ac,p%av(mld_ac_),info) + p%base_a => p%av(mld_ac_) + if (info==0) call psb_cdtransfer(desc_ac,p%desc_ac,info) + + p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,& + & p%desc_ac,p%av(mld_sm_pr_t_),p%av(mld_sm_pr_)) + ! The two matrices from p%av() have been copied, may free them. + if (info == 0) call psb_sp_free(p%av(mld_sm_pr_t_),info) + if (info == 0) call psb_sp_free(p%av(mld_sm_pr_),info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdtransfer') + goto 9999 + end if + p%base_desc => p%desc_ac + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + Return + +end subroutine mld_smlprec_bld diff --git a/mlprec/mld_sprec_aply.f90 b/mlprec/mld_sprec_aply.f90 new file mode 100644 index 00000000..e7ad914a --- /dev/null +++ b/mlprec/mld_sprec_aply.f90 @@ -0,0 +1,260 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sprec_aply.f90 +! +! Subroutine: mld_sprec_aply +! Version: real +! +! This routine applies the preconditioner built by mld_sprecbld, i.e. it computes +! +! Y = op(M^(-1)) * X, +! where +! - M is the preconditioner, +! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors. +! This operation is performed at each iteration of a preconditioned Krylov solver. +! +! +! Arguments: +! prec - type(mld_sprec_type), input. +! The preconditioner data structure containing the local part +! of the preconditioner to be applied. +! x - real(psb_spk_), dimension(:), input. +! The local part of the vector X in Y := op(M^(-1)) * X. +! y - real(psb_spk_), dimension(:), output. +! The local part of the vector Y in Y := op(M^(-1)) * X. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! info - integer, output. +! Error code. +! trans - character(len=1), optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! work - real(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at +! least 4*psb_cd_get_local_cols(desc_data). +! +subroutine mld_sprec_aply(prec,x,y,desc_data,info,trans,work) + + use psb_base_mod + use mld_inner_mod + use mld_prec_mod, mld_protect_name => mld_sprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_), optional, target :: work(:) + + ! Local variables + character :: trans_ + real(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act,iwsz + character(len=20) :: name + + name='mld_sprec_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + iwsz = max(1,4*psb_cd_get_local_cols(desc_data)) + allocate(work_(iwsz),stat=info) + if (info /= 0) then + call psb_errpush(4025,name,i_err=(/iwsz,0,0,0,0/),& + &a_err='real(psb_spk_)') + goto 9999 + end if + + end if + + if (.not.(allocated(prec%baseprecv))) then + !! Error 1: should call mld_sprecbld + info=3112 + call psb_errpush(info,name) + goto 9999 + end if + if (size(prec%baseprecv) >1) then + call mld_mlprec_aply(sone,prec%baseprecv,x,szero,y,desc_data,trans_,work_,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mld_smlprec_aply') + goto 9999 + end if + + else if (size(prec%baseprecv) == 1) then + call mld_baseprec_aply(sone,prec%baseprecv(1),x,szero,y,desc_data,trans_, work_,info) + else + info = 4013 + call psb_errpush(info,name,a_err='Invalid size of baseprecv',& + & i_Err=(/size(prec%baseprecv),0,0,0,0/)) + goto 9999 + endif + + ! If the original distribution has an overlap we should fix that. + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + + if (present(work)) then + else + deallocate(work_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_sprec_aply + + +! +! Subroutine: mld_sprec_aply1 +! Version: real +! +! Applies the preconditioner built by mld_sprecbld, i.e. computes +! +! X = op(M^(-1)) * X, +! where +! - M is the preconditioner, +! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans, +! - X is a vectors. +! This operation is performed at each iteration of a preconditioned Krylov solver. +! +! This routine differs from mld_sprec_aply because the preconditioned vector X +! overwrites the original one. +! +! +! Arguments: +! prec - type(mld_sprec_type), input. +! The preconditioner data structure containing the local part +! of the preconditioner to be applied. +! x - real(psb_spk_), dimension(:), input/output. +! The local part of vector X in X := op(M^(-1)) * X. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! info - integer, output. +! Error code. +! trans - character(len=1), optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! +subroutine mld_sprec_aply1(prec,x,desc_data,info,trans) + + use psb_base_mod + use mld_inner_mod + use mld_prec_mod, mld_protect_name => mld_sprec_aply1 + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + + ! Local variables + integer :: ictxt,np,me, err_act + real(psb_spk_), pointer :: WW(:), w1(:) + character(len=20) :: name + + name='mld_sprec_aply1' + info = 0 + call psb_erractionsave(err_act) + + + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*size(x),0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + call mld_precaply(prec,x,ww,desc_data,info,trans=trans,work=w1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='mld_precaply') + goto 9999 + end if + + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine mld_sprec_aply1 diff --git a/mlprec/mld_sprecbld.f90 b/mlprec/mld_sprecbld.f90 new file mode 100644 index 00000000..0273a3ac --- /dev/null +++ b/mlprec/mld_sprecbld.f90 @@ -0,0 +1,234 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sprecbld.f90 +! +! Subroutine: mld_sprecbld +! Version: real +! Contains: subroutine init_baseprc_av +! +! This routine builds the preconditioner according to the requirements made by +! the user trough the subroutines mld_precinit and mld_precset. +! +! A multilevel preconditioner is regarded as an array of 'base preconditioners', +! each representing the part of the preconditioner associated to a certain level. +! The levels are numbered in increasing order starting from the finest one, i.e. +! level 1 is the finest level. +! +! +! Arguments: +! a - type(psb_sspmat_type). +! The sparse matrix structure containing the local part of the +! matrix to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure containing the local part +! of the preconditioner to be built. +! info - integer, output. +! Error code. +! +subroutine mld_sprecbld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod + use mld_prec_mod, protect => mld_sprecbld + + Implicit None + + ! Arguments + type(psb_sspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(mld_sprec_type),intent(inout) :: p + integer, intent(out) :: info +!!$ character, intent(in), optional :: upd + + ! Local Variables + Integer :: err,i,k,ictxt, me,np, err_act, iszv + integer :: int_err(5) + character :: upd_ + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if (psb_get_errstatus().ne.0) return + info=0 + err=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + name = 'mld_sprecbld' + info = 0 + int_err(1) = 0 + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Entering ',desc_a%matrix_data(:) + ! + ! For the time being we are commenting out the UPDATE argument + ! we plan to resurrect it later. +!!$ if (present(upd)) then +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd +!!$ +!!$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then +!!$ upd_=psb_toupper(upd) +!!$ else +!!$ upd_='F' +!!$ endif +!!$ else +!!$ upd_='F' +!!$ endif + upd_ = 'F' + + if (.not.allocated(p%baseprecv)) then + !! Error: should have called mld_sprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + ! + ! Check to ensure all procs have the same + ! + iszv = size(p%baseprecv) + call psb_bcast(ictxt,iszv) + if (iszv /= size(p%baseprecv)) then + info=4001 + call psb_errpush(info,name,a_err='Inconsistent size of baseprecv') + goto 9999 + end if + + if (iszv >= 1) then + ! + ! Allocate and build the fine level preconditioner + ! + call init_baseprc_av(p%baseprecv(1),info) + if (info == 0) call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,upd_) + + if (info /= 0) then + call psb_errpush(4001,name,a_err='Base level precbuild.') + goto 9999 + end if + + else + info=4010 + ch_err='size bpv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (iszv > 1) then + + ! + ! Build the base preconditioners corresponding to the remaining + ! levels + ! + do i=2, iszv + + ! + ! Allocate the av component of the preconditioner data type + ! at level i + ! + if (i= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + + ! + ! Build the base preconditioner corresponding to level i + ! + if (info == 0) call mld_mlprec_bld(p%baseprecv(i-1)%base_a,& + & p%baseprecv(i-1)%base_desc, p%baseprecv(i),info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='Init & build upper level preconditioner') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + end do + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine init_baseprc_av(p,info) + type(mld_sbaseprc_type), intent(inout) :: p + integer :: info + if (allocated(p%av)) then + if (size(p%av) /= mld_max_avsz_) then + deallocate(p%av,stat=info) + if (info /= 0) return + endif + end if + if (.not.(allocated(p%av))) then + allocate(p%av(mld_max_avsz_),stat=info) + if (info /= 0) return + end if + do k=1,size(p%av) + call psb_nullify_sp(p%av(k)) + end do + + end subroutine init_baseprc_av + +end subroutine mld_sprecbld + diff --git a/mlprec/mld_sprecfree.f90 b/mlprec/mld_sprecfree.f90 new file mode 100644 index 00000000..50f15f18 --- /dev/null +++ b/mlprec/mld_sprecfree.f90 @@ -0,0 +1,94 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sprecfree.f90 +! +! Subroutine: mld_sprecfree +! Version: real +! +! This routine deallocates the preconditioner data structure. +! +! +! Arguments: +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure to be deallocated. +! info - integer, output. +! Error code. +! +subroutine mld_sprecfree(p,info) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_sprecfree + + implicit none + + ! Arguments + type(mld_sprec_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: me,err_act,i + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=0 + name = 'mld_sprecfree' + call psb_erractionsave(err_act) + + me=-1 + + if (allocated(p%baseprecv)) then + do i=1,size(p%baseprecv) + call mld_base_precfree(p%baseprecv(i),info) + end do + deallocate(p%baseprecv) + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_sprecfree diff --git a/mlprec/mld_sprecinit.f90 b/mlprec/mld_sprecinit.f90 new file mode 100644 index 00000000..bb3a41fe --- /dev/null +++ b/mlprec/mld_sprecinit.f90 @@ -0,0 +1,252 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sprecinit.f90 +! +! Subroutine: mld_sprecinit +! Version: real +! +! This routine allocates and initializes the preconditioner data structure, +! according to the preconditioner type chosen by the user. +! +! A default preconditioner is set for each preconditioner type +! specified by the user: +! +! 'NONE', 'NOPREC' - no preconditioner +! +! 'DIAG' - diagonal preconditioner +! +! 'BJAC' - block Jacobi preconditioner, with ILU(0) +! on the local blocks +! +! 'AS' - Restricted Additive Schwarz (RAS), with +! overlap 1 and ILU(0) on the local submatrices +! +! 'ML' - Multilevel hybrid preconditioner (additive on the +! same level and multiplicative through the levels), +! with nlev levels and post-smoothing only. The block +! Jacobi preconditioner, with ILU(0) on the local +! blocks, is applied as post-smoother at each level +! but the coarsest one; four sweeps of the block-Jacobi +! solver, with ILU(0) on the blocks, are applied at +! the coarsest level, on the distributed coarse matrix. +! +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! +! Arguments: +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure. +! ptype - character(len=*), input. +! The type of preconditioner. Its values are 'NONE', +! 'NOPREC', 'DIAG', 'BJAC', 'AS', 'ML' (and the corresponding +! lowercase strings). +! info - integer, output. +! Error code. +! nlev - integer, optional, input. +! The number of levels of the multilevel preconditioner. +! If nlev is not present and ptype='ML', then nlev=2 +! is assumed. If ptype/='ML', nlev is ignored. +! +subroutine mld_sprecinit(p,ptype,info,nlev) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_sprecinit + + implicit none + +! Arguments + type(mld_sprec_type), intent(inout) :: p + character(len=*), intent(in) :: ptype + integer, intent(out) :: info + integer, optional, intent(in) :: nlev + +! Local variables + integer :: nlev_, ilev_ + character(len=*), parameter :: name='mld_precinit' + info = 0 + + if (allocated(p%baseprecv)) then + call mld_precfree(p,info) + if (info /=0) then + ! Do we want to do something? + endif + endif + + select case(psb_toupper(ptype(1:len_trim(ptype)))) + case ('NONE','NOPREC') + nlev_ = 1 + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_noprec_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + + case ('DIAG') + nlev_ = 1 + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_diag_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + + case ('BJAC') + nlev_ = 1 + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + + case ('AS') + nlev_ = 1 + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 1 + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + + + case ('ML') + + if (present(nlev)) then + nlev_ = max(1,nlev) + else + nlev_ = 2 + end if + ilev_ = 1 + allocate(p%baseprecv(nlev_),stat=info) + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + if (nlev_ == 1) return + + do ilev_ = 2, nlev_ -1 + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_ + p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_ + p%baseprecv(ilev_)%iprcparm(mld_smooth_pos_) = mld_post_smooth_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 1 + p%baseprecv(ilev_)%rprcparm(mld_aggr_damp_) = 4.e0/3.e0 + end do + ilev_ = nlev_ + if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) + if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) + if (info /= 0) return + p%baseprecv(ilev_)%iprcparm(:) = 0 + p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ + p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ + p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_n_ovr_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_ + p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_ + p%baseprecv(ilev_)%iprcparm(mld_smooth_pos_) = mld_post_smooth_ + p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_ + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = 0 + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = 4 + p%baseprecv(ilev_)%rprcparm(mld_aggr_damp_) = 4.e0/3.e0 + + case default + write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"' + info = 2 + + end select + + +end subroutine mld_sprecinit diff --git a/mlprec/mld_sprecset.f90 b/mlprec/mld_sprecset.f90 new file mode 100644 index 00000000..613661bf --- /dev/null +++ b/mlprec/mld_sprecset.f90 @@ -0,0 +1,637 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sprecset.f90 +! +! Subroutine: mld_sprecseti +! Version: real +! +! This routine sets the integer parameters defining the preconditioner. More +! precisely, the integer parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set character and real parameters, see mld_sprecsetc and mld_sprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in MLD2P4 user's guide. +! val - integer, input. +! The value of the parameter to be set. The list of allowed +! values is reported in MLD2P4 user's guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +subroutine mld_sprecseti(p,what,val,info,ilev) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_sprecseti + + implicit none + +! Arguments + type(mld_sprec_type), intent(inout) :: p + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + +! Local variables + integer :: ilev_, nlev_ + character(len=*), parameter :: name='mld_precseti' + + info = 0 + + if (.not.allocated(p%baseprecv)) then + info = 3111 + write(0,*) name,': Error: Uninitialized preconditioner, should call MLD_PRECINIT' + return + endif + nlev_ = size(p%baseprecv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + info = -1 + write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + return + endif + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + info = 3111 + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_n_ovr_,mld_sub_fill_in_,mld_smooth_sweeps_) + p%baseprecv(ilev_)%iprcparm(what) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + else if (ilev_ > 1) then + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_n_ovr_,mld_sub_fill_in_,& + & mld_smooth_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + & mld_smooth_pos_,mld_aggr_eig_) + p%baseprecv(ilev_)%iprcparm(what) = val + case(mld_coarse_mat_) + if (ilev_ /= nlev_ .and. val /= mld_distr_mat_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = val + case(mld_coarse_solve_) + if (ilev_ /= nlev_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = val + case(mld_coarse_sweeps_) + if (ilev_ /= nlev_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_smooth_sweeps_) = val + case(mld_coarse_fill_in_) + if (ilev_ /= nlev_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_sub_fill_in_) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate + ! levels + ! + + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_n_ovr_,mld_sub_fill_in_,& + & mld_smooth_sweeps_) + do ilev_=1,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%iprcparm(what) = val + end do + case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + & mld_smooth_pos_,mld_aggr_eig_) + do ilev_=2,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%iprcparm(what) = val + end do + case(mld_coarse_mat_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = val + case(mld_coarse_solve_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val + case(mld_coarse_sweeps_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_smooth_sweeps_) = val + case(mld_coarse_fill_in_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_fill_in_) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + endif + +end subroutine mld_sprecseti + +! +! Subroutine: mld_sprecsetc +! Version: real +! Contains: get_stringval +! +! This routine sets the character parameters defining the preconditioner. More +! precisely, the character parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and real parameters, see mld_sprecseti and mld_sprecsetr, +! respectively. +! +! +! Arguments: +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in MLD2P4 user's guide. +! string - character(len=*), input. +! The value of the parameter to be set. The list of allowed +! values is reported in MLD2P4 user's guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +subroutine mld_sprecsetc(p,what,string,info,ilev) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_sprecsetc + + implicit none + + ! Arguments + type(mld_sprec_type), intent(inout) :: p + integer, intent(in) :: what + character(len=*), intent(in) :: string + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + +! Local variables + integer :: ilev_, nlev_,val + character(len=*), parameter :: name='mld_precseti' + + info = 0 + + if (.not.allocated(p%baseprecv)) then + info = 3111 + return + endif + nlev_ = size(p%baseprecv) + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + info = -1 + return + endif + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = 3111 + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_) + call get_stringval(string,val,info) + p%baseprecv(ilev_)%iprcparm(what) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + else if (ilev_ > 1) then + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + & mld_smooth_pos_,mld_aggr_eig_) + call get_stringval(string,val,info) + p%baseprecv(ilev_)%iprcparm(what) = val + case(mld_coarse_mat_) + call get_stringval(string,val,info) + if (ilev_ /= nlev_ .and. val /= mld_distr_mat_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = val + case(mld_coarse_solve_) + call get_stringval(string,val,info) + if (ilev_ /= nlev_) then + write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate + ! levels + ! + + select case(what) + case(mld_prec_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_) + call get_stringval(string,val,info) + do ilev_=1,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%iprcparm(what) = val + end do + case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + & mld_smooth_pos_) + call get_stringval(string,val,info) + do ilev_=2,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%iprcparm(what) = val + end do + case(mld_coarse_mat_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + call get_stringval(string,val,info) + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = val + case(mld_coarse_solve_) + if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + call get_stringval(string,val,info) + if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + endif + +contains + + ! + ! Subroutine: get_stringval + ! Note: internal subroutine of mld_sprecsetc + ! + ! This routine converts the string contained into string into the corresponding + ! integer value. + ! + ! Arguments: + ! string - character(len=*), input. + ! The string to be converted. + ! val - integer, output. + ! The integer value corresponding to the string + ! info - integer, output. + ! Error code. + ! + subroutine get_stringval(string,val,info) + + ! Arguments + character(len=*), intent(in) :: string + integer, intent(out) :: val, info + + info = 0 + select case(psb_toupper(trim(string))) + case('NONE') + val = 0 + case('HALO') + val = psb_halo_ + case('SUM') + val = psb_sum_ + case('AVG') + val = psb_avg_ + case('ILU') + val = mld_ilu_n_ + case('MILU') + val = mld_milu_n_ + case('ILUT') + val = mld_ilu_t_ + case('UMF') + val = mld_umf_ + case('SLU') + val = mld_slu_ + case('SLUDIST') + val = mld_sludist_ + case('ADD') + val = mld_add_ml_ + case('MULT') + val = mld_mult_ml_ + case('DEC') + val = mld_dec_aggr_ + case('SYMDEC') + val = mld_sym_dec_aggr_ + case('GLB') + val = mld_glb_aggr_ + case('REPL') + val = mld_repl_mat_ + case('DIST') + val = mld_distr_mat_ + case('RAW') + val = mld_no_smooth_ + case('SMOOTH') + val = mld_smooth_prol_ + case('PRE') + val = mld_pre_smooth_ + case('POST') + val = mld_post_smooth_ + case('TWOSIDE','BOTH') + val = mld_twoside_smooth_ + case('NOPREC') + val = mld_noprec_ + case('DIAG') + val = mld_diag_ + case('BJAC') + val = mld_bjac_ + case('AS') + val = mld_as_ + case default + val = -1 + info = -1 + end select + if (info /= 0) then + write(0,*) name,': Error: unknown request: "',trim(string),'"' + end if + end subroutine get_stringval + +end subroutine mld_sprecsetc + + +! +! Subroutine: mld_sprecsetr +! Version: real +! +! This routine sets the real parameters defining the preconditioner. More +! precisely, the real parameter identified by 'what' is assigned the value +! contained in 'val'. +! For the multilevel preconditioners, the levels are numbered in increasing +! order starting from the finest one, i.e. level 1 is the finest level. +! +! To set integer and character parameters, see mld_sprecseti and mld_sprecsetc, +! respectively. +! +! Arguments: +! p - type(mld_sprec_type), input/output. +! The preconditioner data structure. +! what - integer, input. +! The number identifying the parameter to be set. +! A mnemonic constant has been associated to each of these +! numbers, as reported in MLD2P4 user's guide. +! val - real(psb_spk_), input. +! The value of the parameter to be set. The list of allowed +! values is reported in MLD2P4 user's guide. +! info - integer, output. +! Error code. +! ilev - integer, optional, input. +! For the multilevel preconditioner, the level at which the +! preconditioner parameter has to be set. +! If nlev is not present, the parameter identified by 'what' +! is set at all the appropriate levels. +! +subroutine mld_sprecsetr(p,what,val,info,ilev) + + use psb_base_mod + use mld_prec_mod, mld_protect_name => mld_sprecsetr + + implicit none + + ! Arguments + type(mld_sprec_type), intent(inout) :: p + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + +! Local variables + integer :: ilev_,nlev_ + character(len=*), parameter :: name='mld_precsetd' + + info = 0 + + if (present(ilev)) then + ilev_ = ilev + else + ilev_ = 1 + end if + + if (.not.allocated(p%baseprecv)) then + write(0,*) name,': Error: Uninitialized preconditioner, should call MLD_PRECINIT' + info = 3111 + return + endif + nlev_ = size(p%baseprecv) + + if ((ilev_<1).or.(ilev_ > nlev_)) then + write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_ + info = -1 + return + endif + if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = 3111 + return + endif + + ! + ! Set preconditioner parameters at level ilev. + ! + if (present(ilev)) then + + if (ilev_ == 1) then + ! + ! Rules for fine level are slightly different. + ! + select case(what) + case(mld_fact_thrs_) + p%baseprecv(ilev_)%rprcparm(what) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + else if (ilev_ > 1) then + select case(what) + case(mld_aggr_damp_,mld_fact_thrs_) + p%baseprecv(ilev_)%rprcparm(what) = val + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + endif + + else if (.not.present(ilev)) then + ! + ! ilev not specified: set preconditioner parameters at all the appropriate levels + ! + + select case(what) + case(mld_fact_thrs_) + do ilev_=1,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%rprcparm(what) = val + end do + case(mld_aggr_damp_) + do ilev_=2,nlev_-1 + if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then + write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' + info = -1 + return + endif + p%baseprecv(ilev_)%rprcparm(what) = val + end do + case default + write(0,*) name,': Error: invalid WHAT' + info = -2 + end select + + endif + +end subroutine mld_sprecsetr diff --git a/mlprec/mld_sslu_bld.f90 b/mlprec/mld_sslu_bld.f90 new file mode 100644 index 00000000..6d6d5cda --- /dev/null +++ b/mlprec/mld_sslu_bld.f90 @@ -0,0 +1,129 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sslu_bld.f90 +! +! Subroutine: mld_sslu_bld +! Version: real +! +! This routine computes the LU factorization of the local part of the matrix +! stored into a, by using SuperLU. +! +! The matrix to be factorized is +! - either a submatrix of the distributed matrix corresponding to any level +! of a multilevel preconditioner, and its factorization is used to build +! the 'base preconditioner' corresponding to that level, +! - or a copy of the whole matrix corresponding to the coarsest level of +! a multilevel preconditioner, and its factorization is used to build +! the 'base preconditioner' corresponding to the coarsest level. +! +! The data structure allocated by SuperLU to store the L and U factors is +! pointed by p%iprcparm(mld_slu_ptr_). +! +! +! Arguments: +! a - type(psb_sspmat_type), input/output. +! The sparse matrix structure containing the local submatrix to +! be factorized. +! desc_a - type(psb_desc_type), input. +! The communication descriptor associated to a. +! p - type(mld_sbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the pointer, +! p%iprcparm(mld_slu_ptr_), to the data structure used by SuperLU +! to store the L and U factors. +! info - integer, output. +! Error code. +! +subroutine mld_sslu_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_sslu_bld + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: nzt,ictxt,me,np,err_act + character(len=20) :: name, ch_err + + if(psb_get_errstatus().ne.0) return + info=0 + name='mld_sslu_bld' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + if (psb_toupper(a%fida) /= 'CSR') then + info=135 + call psb_errpush(info,name,a_err=a%fida) + goto 9999 + endif + + nzt = psb_sp_get_nnzeros(a) + ! + ! Compute the LU factorization + ! + call mld_sslu_fact(a%m,nzt,& + & a%aspk,a%ia2,a%ia1,p%iprcparm(mld_slu_ptr_),info) + + if (info /= 0) then + ch_err='mld_slu_fact' + call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_sslu_bld + diff --git a/mlprec/mld_sslu_interface.c b/mlprec/mld_sslu_interface.c new file mode 100644 index 00000000..5356e438 --- /dev/null +++ b/mlprec/mld_sslu_interface.c @@ -0,0 +1,391 @@ +/* + * + * MLD2P4 version 1.0 + * MultiLevel Domain Decomposition Parallel Preconditioners Package + * based on PSBLAS (Parallel Sparse BLAS version 2.2) + * + * (C) Copyright 2008 + * + * Salvatore Filippone University of Rome Tor Vergata + * Alfredo Buttari University of Rome Tor Vergata + * Pasqua D'Ambra ICAR-CNR, Naples + * Daniela di Serafino Second University of Naples + * + * 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 MLD2P4 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 MLD2P4 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: mld_slu_interface.c + * + * Functions: mld_sslu_fact_, mld_sslu_solve_, mld_sslu_free_. + * + * This file is an interface to the SuperLU routines for sparse factorization and + * solve. It was obtained by modifying the c_fortran_dgssv.c file from the SuperLU + * source distribution; original copyright terms are reproduced below. + * + */ + + +/* ===================== + +Copyright (c) 2003, The Regents of the University of California, through +Lawrence Berkeley National Laboratory (subject to receipt of any required +approvals from U.S. Dept. of Energy) + +All rights reserved. + +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) Neither the name of Lawrence Berkeley National Laboratory, U.S. Dept. of +Energy nor the names of its contributors may be used to endorse or promote +products derived from this software without specific prior 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 COPYRIGHT OWNER OR +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. + +*/ + +/* + * -- SuperLU routine (version 3.0) -- + * Univ. of California Berkeley, Xerox Palo Alto Research Center, + * and Lawrence Berkeley National Lab. + * October 15, 2003 + * + */ + +#ifdef Have_SLU_ +#include "slu_sdefs.h" + +#define HANDLE_SIZE 8 +/* kind of integer to hold a pointer. Use int. + This might need to be changed on 64-bit systems. */ +#ifdef Ptr64Bits +typedef long long fptr; +#else +typedef int fptr; /* 32-bit by default */ +#endif + +typedef struct { + SuperMatrix *L; + SuperMatrix *U; + int *perm_c; + int *perm_r; +} factors_t; + + +#else + +#include + +#endif + + +#ifdef LowerUnderscore +#define mld_sslu_fact_ mld_sslu_fact_ +#define mld_sslu_solve_ mld_sslu_solve_ +#define mld_sslu_free_ mld_sslu_free_ +#endif +#ifdef LowerDoubleUnderscore +#define mld_sslu_fact_ mld_sslu_fact__ +#define mld_sslu_solve_ mld_sslu_solve__ +#define mld_sslu_free_ mld_sslu_free__ +#endif +#ifdef LowerCase +#define mld_sslu_fact_ mld_sslu_fact +#define mld_sslu_solve_ mld_sslu_solve +#define mld_sslu_free_ mld_sslu_free +#endif +#ifdef UpperUnderscore +#define mld_sslu_fact_ MLD_SSLU_FACT_ +#define mld_sslu_solve_ MLD_SSLU_SOLVE_ +#define mld_sslu_free_ MLD_SSLU_FREE_ +#endif +#ifdef UpperDoubleUnderscore +#define mld_sslu_fact_ MLD_SSLU_FACT__ +#define mld_sslu_solve_ MLD_SSLU_SOLVE__ +#define mld_sslu_free_ MLD_SSLU_FREE__ +#endif +#ifdef UpperCase +#define mld_sslu_fact_ MLD_SSLU_FACT +#define mld_sslu_solve_ MLD_SSLU_SOLVE +#define mld_sslu_free_ MLD_SSLU_FREE +#endif + + + + +void +mld_sslu_fact_(int *n, int *nnz, + float *values, int *rowptr, int *colind, +#ifdef Have_SLU_ + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * performs LU decomposition. + * + * f_factors (input/output) fptr* + * On output contains the pointer pointing to + * the structure of the factored matrices. + * + */ + +#ifdef Have_SLU_ + SuperMatrix A, AC; + SuperMatrix *L, *U; + int *perm_r; /* row permutations from partial pivoting */ + int *perm_c; /* column permutation vector */ + int *etree; /* column elimination tree */ + SCformat *Lstore; + NCformat *Ustore; + int i, panel_size, permc_spec, relax; + trans_t trans; + float drop_tol = 0.0; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + trans = NOTRANS; + + + /* Set the default input options. */ + set_default_options(&options); + + /* Initialize the statistics variables. */ + StatInit(&stat); + + /* Adjust to 0-based indexing */ + for (i = 0; i < *nnz; ++i) --colind[i]; + for (i = 0; i <= *n; ++i) --rowptr[i]; + + sCreate_CompRow_Matrix(&A, *n, *n, *nnz, values, colind, rowptr, + SLU_NR, SLU_S, SLU_GE); + L = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) ); + U = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) ); + if ( !(perm_r = intMalloc(*n)) ) ABORT("Malloc fails for perm_r[]."); + if ( !(perm_c = intMalloc(*n)) ) ABORT("Malloc fails for perm_c[]."); + if ( !(etree = intMalloc(*n)) ) ABORT("Malloc fails for etree[]."); + + /* + * Get column permutation vector perm_c[], according to permc_spec: + * permc_spec = 0: natural ordering + * permc_spec = 1: minimum degree on structure of A'*A + * permc_spec = 2: minimum degree on structure of A'+A + * permc_spec = 3: approximate minimum degree for unsymmetric matrices + */ + options.ColPerm=2; + permc_spec = options.ColPerm; + get_perm_c(permc_spec, &A, perm_c); + + sp_preorder(&options, &A, perm_c, etree, &AC); + + panel_size = sp_ienv(1); + relax = sp_ienv(2); + + sgstrf(&options, &AC, drop_tol, relax, panel_size, + etree, NULL, 0, perm_c, perm_r, L, U, &stat, info); + + if ( *info == 0 ) { + Lstore = (SCformat *) L->Store; + Ustore = (NCformat *) U->Store; + sQuerySpace(L, U, &mem_usage); +#if 0 + printf("No of nonzeros in factor L = %d\n", Lstore->nnz); + printf("No of nonzeros in factor U = %d\n", Ustore->nnz); + printf("No of nonzeros in L+U = %d\n", Lstore->nnz + Ustore->nnz); + printf("L\\U MB %.3f\ttotal MB needed %.3f\texpansions %d\n", + mem_usage.for_lu/1e6, mem_usage.total_needed/1e6, + mem_usage.expansions); +#endif + } else { + printf("dgstrf() error returns INFO= %d\n", *info); + if ( *info <= *n ) { /* factorization completes */ + sQuerySpace(L, U, &mem_usage); + printf("L\\U MB %.3f\ttotal MB needed %.3f\texpansions %d\n", + mem_usage.for_lu/1e6, mem_usage.total_needed/1e6, + mem_usage.expansions); + } + } + + /* Restore to 1-based indexing */ + for (i = 0; i < *nnz; ++i) ++colind[i]; + for (i = 0; i <= *n; ++i) ++rowptr[i]; + + /* Save the LU factors in the factors handle */ + LUfactors = (factors_t*) SUPERLU_MALLOC(sizeof(factors_t)); + LUfactors->L = L; + LUfactors->U = U; + LUfactors->perm_c = perm_c; + LUfactors->perm_r = perm_r; + *f_factors = (fptr) LUfactors; + + /* Free un-wanted storage */ + SUPERLU_FREE(etree); + Destroy_SuperMatrix_Store(&A); + Destroy_CompCol_Permuted(&AC); + StatFree(&stat); +#else + fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + +void +mld_sslu_solve_(int *itrans, int *n, int *nrhs, + float *b, int *ldb, +#ifdef Have_SLU_ + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * performs triangular solve + * + */ +#ifdef Have_SLU_ + SuperMatrix A, AC, B; + SuperMatrix *L, *U; + int *perm_r; /* row permutations from partial pivoting */ + int *perm_c; /* column permutation vector */ + int *etree; /* column elimination tree */ + SCformat *Lstore; + NCformat *Ustore; + int i, panel_size, permc_spec, relax; + trans_t trans; + float drop_tol = 0.0; + SuperLUStat_t stat; + factors_t *LUfactors; + + if (*itrans == 0) { + trans = NOTRANS; + } else if (*itrans ==1) { + trans = TRANS; + } else if (*itrans ==2) { + trans = CONJ; + } else { + trans = NOTRANS; + } + /* Initialize the statistics variables. */ + StatInit(&stat); + + /* Extract the LU factors in the factors handle */ + LUfactors = (factors_t*) *f_factors; + L = LUfactors->L; + U = LUfactors->U; + perm_c = LUfactors->perm_c; + perm_r = LUfactors->perm_r; + + sCreate_Dense_Matrix(&B, *n, *nrhs, b, *ldb, SLU_DN, SLU_S, SLU_GE); + /* Solve the system A*X=B, overwriting B with X. */ + sgstrs (trans, L, U, perm_c, perm_r, &B, &stat, info); + + Destroy_SuperMatrix_Store(&B); + StatFree(&stat); +#else + fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif + +} + + +void +mld_sslu_free_( +#ifdef Have_SLU_ + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * + * free all storage in the end + * + */ +#ifdef Have_SLU_ + SuperMatrix A, AC, B; + SuperMatrix *L, *U; + int *perm_r; /* row permutations from partial pivoting */ + int *perm_c; /* column permutation vector */ + int *etree; /* column elimination tree */ + SCformat *Lstore; + NCformat *Ustore; + int i, panel_size, permc_spec, relax; + trans_t trans; + float drop_tol = 0.0; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + trans = NOTRANS; + /* Free the LU factors in the factors handle */ + LUfactors = (factors_t*) *f_factors; + SUPERLU_FREE (LUfactors->perm_r); + SUPERLU_FREE (LUfactors->perm_c); + Destroy_SuperNode_Matrix(LUfactors->L); + Destroy_CompCol_Matrix(LUfactors->U); + SUPERLU_FREE (LUfactors->L); + SUPERLU_FREE (LUfactors->U); + SUPERLU_FREE (LUfactors); + *info = 0; +#else + fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + diff --git a/mlprec/mld_sslud_bld.f90 b/mlprec/mld_sslud_bld.f90 new file mode 100644 index 00000000..0b450b18 --- /dev/null +++ b/mlprec/mld_sslud_bld.f90 @@ -0,0 +1,148 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sslud_bld.f90 +! +! Subroutine: mld_ssludist_bld +! Version: real +! +! This routine computes the LU factorization of of a distributed matrix, +! by using SuperLU_DIST. +! +! The matrix to be factorized is the coarsest level matrix of a multilevel +! preconditioner and is distributed among the processes. Its factorization +! is used to build the 'base preconditioner' corresponding to the coarsest +! level. +! +! The data structure allocated by SuperLU_DIST to store the L and U factors +! is pointed by p%iprcparm(mld_slud_ptr_). +! +! +! Arguments: +! a - type(psb_sspmat_type), input/output. +! The sparse matrix structure containing the local part of the +! matrix to be factorized. +! desc_a - type(psb_desc_type), input. +! The communication descriptor associated to a. +! p - type(mld_sbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the pointer, +! p%iprcparm(mld_slud_ptr_), to the data structure used by +! SuperLU_DIST to store the L and U factors. +! info - integer, output. +! Error code. +! +subroutine mld_ssludist_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_ssludist_bld + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: nzt,ictxt,me,np,err_act,& + & mglob,ifrst,ibcheck,nrow,ncol,npr,npc + character(len=20) :: name, ch_err + + if (psb_get_errstatus().ne.0) return + info=0 + name='mld_sslud_bld' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + if (psb_toupper(a%fida) /= 'CSR') then + info=135 + call psb_errpush(info,name,a_err=a%fida) + goto 9999 + endif + + ! + ! WARN: we need to check for a BLOCK distribution (this is the + ! distribution required by SuperLU_DIST) + ! + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + ifrst = desc_a%loc_to_glob(1) + ibcheck = desc_a%loc_to_glob(nrow) - ifrst + 1 + ibcheck = ibcheck - nrow + call psb_amx(ictxt,ibcheck) + if (ibcheck > 0) then + write(0,*) 'Warning: does not look like a BLOCK distribution' + endif + + mglob = psb_cd_get_global_rows(desc_a) + nzt = psb_sp_get_nnzeros(a) + + npr = np + npc = 1 + call psb_loc_to_glob(a%ia1(1:nzt),desc_a,info,iact='I') + + ! + ! Compute the LU factorization + ! + call mld_ssludist_fact(mglob,nrow,nzt,ifrst,& + & a%aspk,a%ia2,a%ia1,p%iprcparm(mld_slud_ptr_),& + & npr, npc, info) + if (info /= 0) then + ch_err='psb_sludist_fact' + call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + call psb_glob_to_loc(a%ia1(1:nzt),desc_a,info,iact='I') + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_ssludist_bld diff --git a/mlprec/mld_sslud_interface.c b/mlprec/mld_sslud_interface.c new file mode 100644 index 00000000..3229dc52 --- /dev/null +++ b/mlprec/mld_sslud_interface.c @@ -0,0 +1,401 @@ +/* + * + * MLD2P4 version 1.0 + * MultiLevel Domain Decomposition Parallel Preconditioners Package + * based on PSBLAS (Parallel Sparse BLAS version 2.2) + * + * (C) Copyright 2008 + * + * Salvatore Filippone University of Rome Tor Vergata + * Alfredo Buttari University of Rome Tor Vergata + * Pasqua D'Ambra ICAR-CNR, Naples + * Daniela di Serafino Second University of Naples + * + * 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 MLD2P4 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 MLD2P4 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: mld_slud_interface.c + * + * Functions: mld_ssludist_fact_, mld_ssludist_solve_, mld_ssludist_free_. + * + * This file is an interface to the SuperLU_dist routines for sparse factorization and + * solve. It was obtained by modifying the c_fortran_dgssv.c file from the SuperLU_dist + * source distribution; original copyright terms are reproduced below. + * + */ + +/* ===================== + +Copyright (c) 2003, The Regents of the University of California, through +Lawrence Berkeley National Laboratory (subject to receipt of any required +approvals from U.S. Dept. of Energy) + +All rights reserved. + +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) Neither the name of Lawrence Berkeley National Laboratory, U.S. Dept. of +Energy nor the names of its contributors may be used to endorse or promote +products derived from this software without specific prior 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 COPYRIGHT OWNER OR +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. + +*/ + +/* + * -- Distributed SuperLU routine (version 2.0) -- + * Lawrence Berkeley National Lab, Univ. of California Berkeley. + * March 15, 2003 + * + */ + +/* as of v 2.1 SLUDist does not have a single precision interface */ +#ifdef Have_SLUDist_ +#undef Have_SLUDist_ +#endif + +#ifdef Have_SLUDist_ +#include +#include "superlu_sdefs.h" + +#define HANDLE_SIZE 8 +/* kind of integer to hold a pointer. Use int. + This might need to be changed on 64-bit systems. */ +#ifdef Ptr64Bits +typedef long long fptr; +#else +typedef int fptr; /* 32-bit by default */ +#endif + +typedef struct { + SuperMatrix *A; + LUstruct_t *LUstruct; + gridinfo_t *grid; + ScalePermstruct_t *ScalePermstruct; +} factors_t; + + +#else + +#include + +#endif + + +#ifdef LowerUnderscore +#define mld_ssludist_fact_ mld_ssludist_fact_ +#define mld_ssludist_solve_ mld_ssludist_solve_ +#define mld_ssludist_free_ mld_ssludist_free_ +#endif +#ifdef LowerDoubleUnderscore +#define mld_ssludist_fact_ mld_ssludist_fact__ +#define mld_ssludist_solve_ mld_ssludist_solve__ +#define mld_ssludist_free_ mld_ssludist_free__ +#endif +#ifdef LowerCase +#define mld_ssludist_fact_ mld_ssludist_fact +#define mld_ssludist_solve_ mld_ssludist_solve +#define mld_ssludist_free_ mld_ssludist_free +#endif +#ifdef UpperUnderscore +#define mld_ssludist_fact_ MLD_SSLUDIST_FACT_ +#define mld_ssludist_solve_ MLD_SSLUDIST_SOLVE_ +#define mld_ssludist_free_ MLD_SSLUDIST_FREE_ +#endif +#ifdef UpperDoubleUnderscore +#define mld_ssludist_fact_ MLD_SSLUDIST_FACT__ +#define mld_ssludist_solve_ MLD_SSLUDIST_SOLVE__ +#define mld_ssludist_free_ MLD_SSLUDIST_FREE__ +#endif +#ifdef UpperCase +#define mld_ssludist_fact_ MLD_SSLUDIST_FACT +#define mld_ssludist_solve_ MLD_SSLUDIST_SOLVE +#define mld_ssludist_free_ MLD_SSLUDIST_FREE +#endif + + + + +void +mld_ssludist_fact_(int *n, int *nl, int *nnzl, int *ffstr, + double *values, int *rowptr, int *colind, +#ifdef Have_SLUDist_ + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *f_factors, +#endif + int *nprow, int *npcol, int *info) + +{ +/* + * This routine can be called from Fortran. + * performs LU decomposition. + * + * f_factors (input/output) fptr* + * On output contains the pointer pointing to + * the structure of the factored matrices. + * + */ + +#ifdef Have_SLUDist_ + SuperMatrix *A; + NRformat_loc *Astore; + + ScalePermstruct_t *ScalePermstruct; + LUstruct_t *LUstruct; + SOLVEstruct_t SOLVEstruct; + gridinfo_t *grid; + int i, panel_size, permc_spec, relax; + trans_t trans; + double drop_tol = 0.0,b[1],berr[1]; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + int fst_row; + int *icol,*irpt; + double *ival; + + trans = NOTRANS; +/* fprintf(stderr,"Entry to sludist_fact\n"); */ + grid = (gridinfo_t *) SUPERLU_MALLOC(sizeof(gridinfo_t)); + superlu_gridinit(MPI_COMM_WORLD, *nprow, *npcol, grid); + /* Initialize the statistics variables. */ + PStatInit(&stat); + fst_row = (*ffstr) -1; + /* Adjust to 0-based indexing */ + icol = (int *) malloc((*nnzl)*sizeof(int)); + irpt = (int *) malloc(((*nl)+1)*sizeof(int)); + ival = (double *) malloc((*nnzl)*sizeof(double)); + for (i = 0; i < *nnzl; ++i) ival[i] = values[i]; + for (i = 0; i < *nnzl; ++i) icol[i] = colind[i] -1; + for (i = 0; i <= *nl; ++i) irpt[i] = rowptr[i] -1; + + A = (SuperMatrix *) malloc(sizeof(SuperMatrix)); + dCreate_CompRowLoc_Matrix_dist(A, *n, *n, *nnzl, *nl, fst_row, + ival, icol, irpt, + SLU_NR_loc, SLU_D, SLU_GE); + + /* Initialize ScalePermstruct and LUstruct. */ + ScalePermstruct = (ScalePermstruct_t *) SUPERLU_MALLOC(sizeof(ScalePermstruct_t)); + LUstruct = (LUstruct_t *) SUPERLU_MALLOC(sizeof(LUstruct_t)); + ScalePermstructInit(*n,*n, ScalePermstruct); + LUstructInit(*n,*n, LUstruct); + + /* Set the default input options. */ + set_default_options_dist(&options); + options.IterRefine=NO; + options.PrintStat=NO; + + pdgssvx(&options, A, ScalePermstruct, b, *nl, 0, + grid, LUstruct, &SOLVEstruct, berr, &stat, info); + + if ( *info == 0 ) { + ; + } else { + printf("pdgssvx() error returns INFO= %d\n", *info); + if ( *info <= *n ) { /* factorization completes */ + ; + } + } + if (options.SolveInitialized) { + dSolveFinalize(&options,&SOLVEstruct); + } + + + /* Save the LU factors in the factors handle */ + LUfactors = (factors_t *) SUPERLU_MALLOC(sizeof(factors_t)); + LUfactors->LUstruct = LUstruct; + LUfactors->grid = grid; + LUfactors->A = A; + LUfactors->ScalePermstruct = ScalePermstruct; +/* fprintf(stderr,"slud factor: LUFactors %p \n",LUfactors); */ +/* fprintf(stderr,"slud factor: A %p %p\n",A,LUfactors->A); */ +/* fprintf(stderr,"slud factor: grid %p %p\n",grid,LUfactors->grid); */ +/* fprintf(stderr,"slud factor: LUstruct %p %p\n",LUstruct,LUfactors->LUstruct); */ + *f_factors = (fptr) LUfactors; + + PStatFree(&stat); +#else + fprintf(stderr," SLUDist Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + +void +mld_ssludist_solve_(int *itrans, int *n, int *nrhs, + double *b, int *ldb, +#ifdef Have_SLUDist_ + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * performs triangular solve + * + */ +#ifdef Have_SLUDist_ + SuperMatrix *A; + ScalePermstruct_t *ScalePermstruct; + LUstruct_t *LUstruct; + SOLVEstruct_t SOLVEstruct; + gridinfo_t *grid; + int i, panel_size, permc_spec, relax; + trans_t trans; + double drop_tol = 0.0; + double *berr; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + LUfactors = (factors_t *) *f_factors ; + A = LUfactors->A ; + LUstruct = LUfactors->LUstruct ; + grid = LUfactors->grid ; + + ScalePermstruct = LUfactors->ScalePermstruct; +/* fprintf(stderr,"slud solve: LUFactors %p \n",LUfactors); */ +/* fprintf(stderr,"slud solve: A %p %p\n",A,LUfactors->A); */ +/* fprintf(stderr,"slud solve: grid %p %p\n",grid,LUfactors->grid); */ +/* fprintf(stderr,"slud solve: LUstruct %p %p\n",LUstruct,LUfactors->LUstruct); */ + + + if (*itrans == 0) { + trans = NOTRANS; + } else if (*itrans ==1) { + trans = TRANS; + } else if (*itrans ==2) { + trans = CONJ; + } else { + trans = NOTRANS; + } + +/* fprintf(stderr,"Entry to sludist_solve\n"); */ + berr = (double *) malloc((*nrhs) *sizeof(double)); + + /* Initialize the statistics variables. */ + PStatInit(&stat); + + /* Set the default input options. */ + set_default_options_dist(&options); + options.IterRefine = NO; + options.Fact = FACTORED; + options.PrintStat = NO; + + pdgssvx(&options, A, ScalePermstruct, b, *ldb, *nrhs, + grid, LUstruct, &SOLVEstruct, berr, &stat, info); + +/* fprintf(stderr,"Double check: after solve %d %lf\n",*info,berr[0]); */ + if (options.SolveInitialized) { + dSolveFinalize(&options,&SOLVEstruct); + } + PStatFree(&stat); + free(berr); +#else + fprintf(stderr," SLUDist Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif + +} + + +void +mld_ssludist_free_( +#ifdef Have_SLUDist_ + fptr *f_factors, /* a handle containing the address + pointing to the factored matrices */ +#else + void *f_factors, +#endif + int *info) + +{ +/* + * This routine can be called from Fortran. + * + * free all storage in the end + * + */ +#ifdef Have_SLUDist_ + SuperMatrix *A; + ScalePermstruct_t *ScalePermstruct; + LUstruct_t *LUstruct; + SOLVEstruct_t SOLVEstruct; + gridinfo_t *grid; + int i, panel_size, permc_spec, relax; + trans_t trans; + double drop_tol = 0.0; + double *berr; + mem_usage_t mem_usage; + superlu_options_t options; + SuperLUStat_t stat; + factors_t *LUfactors; + + LUfactors = (factors_t *) *f_factors ; + A = LUfactors->A ; + LUstruct = LUfactors->LUstruct ; + grid = LUfactors->grid ; + ScalePermstruct = LUfactors->ScalePermstruct; + + Destroy_CompRowLoc_Matrix_dist(A); + ScalePermstructFree(ScalePermstruct); + LUstructFree(LUstruct); + superlu_gridexit(grid); + + free(grid); + free(LUstruct); + free(LUfactors); + +#else + fprintf(stderr," SLUDist Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + diff --git a/mlprec/mld_ssp_renum.f90 b/mlprec/mld_ssp_renum.f90 new file mode 100644 index 00000000..f001529a --- /dev/null +++ b/mlprec/mld_ssp_renum.f90 @@ -0,0 +1,368 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_ssp_renum.f90 +! +! Subroutine: mld_ssp_renum +! Version: real +! Contains: gps_reduction +! +! This routine reorders the rows and the columns of the local part of a sparse +! distributed matrix, according to one of the following criteria: +! 1. the numbering of the global column indices, +! 2. the Gibbs-Poole-Stockmeyer (GPS) band reduction algorithm. +! NOTE: the GPS algorithm is disabled for the time being (see mld_prec_type.f90). +! +! The matrix to be reordered is stored into a and blck, as specified in the +! description of the arguments below. +! +! If required by the user (p%iprcparm(mld_sub_ren_) /= 0), the routine is +! used by mld_fact_bld in building the block-Jacobi and Additive Schwarz +! 'base preconditioners' corresponding to any level of a multilevel +! preconditioner. +! +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the 'original' local +! part of the matrix to be reordered, i.e. the rows of the matrix +! held by the calling process according to the initial data +! distribution. +! blck - type(psb_sspmat_type), input. +! The sparse matrix structure containing the remote rows of the +! matrix to be reordered, that have been retrieved by mld_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0.If the overlap is 0, then blck does not contain +! any row. +! p - type(mld_sbaseprc_type), input/output. +! The base preconditioner data structure containing the local +! part of the base preconditioner to be built. In input it +! contains information on the type of reordering to be applied +! and on the matrix to be reordered. In output it contains +! information on the reordering applied. +! atmp - type(psb_sspmat_type), output. +! The sparse matrix structure containing the whole local reordered +! matrix. +! info - integer, output. +! Error code. +! +subroutine mld_ssp_renum(a,blck,p,atmp,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_ssp_renum + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in) :: a,blck + type(psb_sspmat_type), intent(out) :: atmp + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + character(len=20) :: name, ch_err + integer :: nztota, nztotb, nztmp, nnr, i,k + integer, allocatable :: itmp(:), itmp2(:) + integer :: ictxt,np,me, err_act + real(psb_dpk_) :: t3,t4 + + if (psb_get_errstatus().ne.0) return + info=0 + name='mld_ssp_renum' + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(p%desc_data) + call psb_info(ictxt, me, np) + + ! + ! NOTE: the matrix to be reordered is converted into the COO format. + ! If necessary it is converted from the COO to the CSR format. + ! The output matrix is in COO format. + ! + + ! + ! Convert a into the COO format and extend it up to a%m+blck%m rows + ! by adding null rows. The converted extended matrix is stored in atmp. + ! + nztota=psb_sp_get_nnzeros(a) + nztotb=psb_sp_get_nnzeros(blck) + call psb_spcnv(a,atmp,info,afmt='coo',dupl=psb_dupl_add_) + call psb_rwextd(a%m+blck%m,atmp,info,blck) + + if (p%iprcparm(mld_sub_ren_)==mld_renum_glb_) then + + ! + ! Remember: we have switched IA1=COLS and IA2=ROWS. + ! Now identify the set of distinct local column indices. + ! + nnr = p%desc_data%matrix_data(psb_n_row_) + allocate(p%perm(nnr),p%invperm(nnr),itmp2(nnr),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + do i=1, nnr + itmp2(i) = i + end do + call psb_loc_to_glob(itmp2(1:nnr),p%desc_data,info,iact='I') + ! + ! Compute reordering. We want new(i) = old(perm(i)). + ! + call psb_msort(itmp2(1:nnr),ix=p%perm) + ! + ! Compute the inverse of the permutation stored in perm + ! + do k=1, nnr + p%invperm(p%perm(k)) = k + enddo + t3 = psb_wtime() + + else if (p%iprcparm(mld_sub_ren_)==mld_renum_gps_) then + + ! + ! This is a renumbering with Gibbs-Poole-Stockmeyer + ! band reduction. Switched off for now. To be fixed, + ! gps_reduction should get p%perm. + ! + + ! + ! Convert atmp into the CSR format + ! + call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) + nztmp = psb_sp_get_nnzeros(atmp) + + ! + ! Realloc the permutation arrays + ! + call psb_realloc(atmp%m,p%perm,info) + if(info/=0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_realloc(atmp%m,p%invperm,info) + if(info/=0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(itmp(max(8,atmp%m+2,nztmp+2)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + itmp(1:8) = 0 + + ! + ! Renumber rows and columns according to the GPS algorithm + ! + call gps_reduction(atmp%m,atmp%ia2,atmp%ia1,p%perm,p%invperm,info) + if(info/=0) then + info=4010 + ch_err='gps_reduction' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Compute the inverse permutation + ! + do k=1, atmp%m + p%invperm(p%perm(k)) = k + enddo + t3 = psb_wtime() + + call psb_spcnv(atmp,info,afmt='coo',dupl=psb_dupl_add_) + + end if + + ! + ! Rebuild atmp with the new numbering (COO format) + ! + nztmp=psb_sp_get_nnzeros(atmp) + do i=1,nztmp + atmp%ia1(i) = p%perm(a%ia1(i)) + atmp%ia2(i) = p%invperm(a%ia2(i)) + end do + call psb_spcnv(atmp,info,afmt='coo',dupl=psb_dupl_add_) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_fixcoo') + goto 9999 + end if + + t4 = psb_wtime() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + ! + ! Subroutine: gps_reduction + ! Note: internal subroutine of mld_ssp_renum + ! + ! Compute a renumbering of the row and column indices of a sparse matrix + ! according to the Gibbs-Poole-Stockmeyer band reduction algorithm. The + ! matrix is stored in CSR format. + ! + ! This routine has been obtained by adapting ACM TOMS Algorithm 582. + ! + ! + ! Arguments: + ! m - integer, ... + ! The number of rows of the matrix to which the renumbering + ! is applied. + ! ia - integer, dimension(:), ... + ! The indices identifying the first nonzero entry of each row + ! of the matrix, according to the CSR storage format. + ! ja - integer, dimension(:), ... + ! The column indices of the nonzero entries of the matrix, + ! according to the CSR storage format. + ! perm - integer, dimension(:), ... + ! The row/column index permutation corresponding to the + ! renumbering. + ! iperm - integer, dimension(:),... + ! The inverse of the row/column permutation stored in perm. + ! info - integer, output. + ! Error code + ! + subroutine gps_reduction(m,ia,ja,perm,iperm,info) + + ! Arguments + integer :: m + integer,dimension(:) :: ia,ja,perm,iperm + integer, intent(out) :: info + + ! Local variables + integer :: i,j,dgConn,Npnt + integer :: n,idpth,ideg,ibw2,ipf2 + integer,dimension(:,:),allocatable::NDstk + integer,dimension(:),allocatable::iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=0 + name='gps_reduction' + call psb_erractionsave(err_act) + + ! Compute the maximum connectivity degree + npnt = m + dgConn=0 + do i=1,m + dgconn = max(dgconn,(ia(i+1)-ia(i))) + enddo + ! The maximum connectivity value is dgConn + + n=Npnt ! Max number of rows + iDeg=dgConn ! Max connectivity + ! iDpth= ! Number of level (initialization not needed) + + allocate(NDstk(Npnt,dgConn),stat=info) + if (info/=0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + endif + allocate(iOld(Npnt),renum(Npnt+1),ndeg(Npnt),lvl(Npnt),lvls1(Npnt),& + &lvls2(Npnt),ccstor(Npnt),stat=info) + if (info/=0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + endif + + ! Prepare the matrix graph + Ndstk(:,:)=0 + do i=1,Npnt + k=0 + do j = ia(i),ia(i+1) - 1 + if ((1<=ja(j)).and.( ja( j ) /= i ).and.(ja(j)<=npnt)) then + k = k+1 + Ndstk(i,k)=ja(j) + endif + enddo + ndeg(i)=k + enddo + + ! Numbering + do i=1,Npnt + iOld(i)=i + enddo + + ! Call gps_reduce + call psb_gps_reduce(Ndstk,Npnt,iOld,renum,ndeg,lvl,lvls1, lvls2,ccstor,& + & ibw2,ipf2,n,idpth,ideg) + + ! Build permutation vector + perm(1:Npnt)=renum(1:Npnt) + + !Build inverse permutation vector + do i=1,Npnt + iperm(perm(i))=i + enddo + + ! Deallocate memory + deallocate(NDstk,iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine gps_reduction + +end subroutine mld_ssp_renum diff --git a/mlprec/mld_ssub_aply.f90 b/mlprec/mld_ssub_aply.f90 new file mode 100644 index 00000000..9e5c60e8 --- /dev/null +++ b/mlprec/mld_ssub_aply.f90 @@ -0,0 +1,296 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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 mld_ssub_aply.f90 +! +! Subroutine: mld_ssub_aply +! Version: real +! +! This routine computes +! +! Y = beta*Y + alpha*op(K^(-1))*X, +! +! where +! - K is a suitable matrix, as specified below, +! - op(K^(-1)) is K^(-1) or its transpose, according to the value of the +! argument trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! Depending on K, alpha and beta (and on the communication descriptor desc_data +! - see the arguments below), the above computation may correspond to one of +! the following tasks: +! +! 1. Application of a block-Jacobi preconditioner associated to a matrix A +! distributed among the processes. Here K is the preconditioner, op(K^(-1)) +! = K^(-1), alpha = 1 and beta = 0. +! +! 2. Application of block-Jacobi sweeps to compute an approximate solution of +! a linear system +! A*Y = X, +! +! distributed among the processes (note that a single block-Jacobi sweep, +! with null starting guess, corresponds to the application of a block-Jacobi +! preconditioner). Here K^(-1) denotes the iteration matrix of the +! block-Jacobi solver, op(K^(-1)) = K^(-1), alpha = 1 and beta = 0. +! +! 3. Solution, through the LU factorization, of a linear system +! +! A*Y = X, +! +! distributed among the processes. Here K = L*U = A, op(K^(-1)) = K^(-1), +! alpha = 1 and beta = 0. +! +! 4. (Approximate) solution, through the LU or incomplete LU factorization, of +! a linear system +! A*Y = X, +! +! replicated on the processes. Here K = L*U = A or K = L*U ~ A, op(K^(-1)) = +! K^(-1), alpha = 1 and beta = 0. +! +! The block-Jacobi preconditioner or solver and the L and U factors of the LU +! or ILU factorizations have been built by the routine mld_fact_bld and stored +! into the 'base preconditioner' data structure prec. See mld_fact_bld for more +! details. +! +! This routine is used by mld_as_aply, to apply a 'base' block-Jacobi or +! Additive Schwarz (AS) preconditioner at any level of a multilevel preconditioner, +! or a block-Jacobi or LU or ILU solver at the coarsest level of a multilevel +! preconditioner. +! +! Tasks 1, 3 and 4 may be selected when prec%iprcparm(smooth_sweeps_) = 1, +! while task 2 is selected when prec%iprcparm(smooth_sweeps_) > 1. Furthermore +! Tasks 1, 2 and 3 may be performed when the matrix A is +! distributed among the processes (prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_), +! while task 4 may be performed when A is replicated on the processes +! (prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_). Note that the matrix A is +! distributed among the processes at each level of the multilevel preconditioner, +! except the coarsest one, where it may be either distributed or replicated on +! the processes. Tasks 2, 3 and 4 are performed only at the coarsest level. +! Note also that this routine manages implicitly the fact that +! the matrix is distributed or replicated, i.e. it does not make any explicit +! reference to the value of prec%iprcparm(mld_coarse_mat_). +! +! Arguments: +! +! alpha - real(psb_spk_), input. +! The scalar alpha. +! prec - type(mld_sbaseprec_type), input. +! The 'base preconditioner' data structure containing the local +! part of the preconditioner or solver. +! x - real(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - real(psb_spk_), input. +! The scalar beta. +! y - real(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned or 'inverted'. +! trans - character(len=1), input. +! If trans='N','n' then op(K^(-1)) = K^(-1); +! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). +! If prec%iprcparm(smooth_sweeps_) > 1, the value of trans provided +! in input is ignored. +! work - real(psb_spk_), dimension (:), target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +subroutine mld_ssub_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_ssub_aply + + implicit none + + ! Arguments + type(psb_desc_type), intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: prec + real(psb_spk_),intent(in) :: 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, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act + character(len=20) :: name + character :: trans_ + + name='mld_ssub_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + + if (prec%iprcparm(mld_smooth_sweeps_) == 1) then + + call mld_sub_solve(alpha,prec,x,beta,y,desc_data,trans_,aux,info) + + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else if (prec%iprcparm(mld_smooth_sweeps_) > 1) then + ! + ! + ! Apply prec%iprcparm(smooth_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + + if (size(prec%av) < mld_ap_nd_) then + info = 4011 + goto 9999 + endif + + allocate(tx(n_col),ty(n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/2*n_col,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + tx = szero + ty = szero + do i=1, prec%iprcparm(mld_smooth_sweeps_) + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + ty(1:n_row) = x(1:n_row) + call psb_spmm(-sone,prec%av(mld_ap_nd_),tx,sone,ty,& + & prec%desc_data,info,work=aux,trans=trans_) + + if (info /=0) exit + + call mld_sub_solve(sone,prec,ty,szero,tx,desc_data,trans_,aux,info) + + if (info /=0) exit + end do + + if (info == 0) call psb_geaxpby(alpha,tx,beta,y,desc_data,info) + + if (info /= 0) then + info=4001 + call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + deallocate(tx,ty,stat=info) + if (info /= 0) then + info=4001 + call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1') + goto 9999 + end if + + else + + info = 10 + call psb_errpush(info,name,& + & i_err=(/2,prec%iprcparm(mld_smooth_sweeps_),0,0,0/)) + goto 9999 + + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_ssub_aply + diff --git a/mlprec/mld_ssub_solve.f90 b/mlprec/mld_ssub_solve.f90 new file mode 100644 index 00000000..3dd46115 --- /dev/null +++ b/mlprec/mld_ssub_solve.f90 @@ -0,0 +1,312 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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 mld_ssub_solve.f90 +! +! Subroutine: mld_ssub_solve +! Version: real +! +! This routine computes +! +! Y = beta*Y + alpha*op(K^(-1))*X, +! +! where +! - K is a factored matrix, as specified below, +! - op(K^(-1)) is K^(-1) or its transpose, according to the value of the +! argument trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! Depending on K, alpha and beta (and on the communication descriptor desc_data +! - see the arguments below), the above computation may correspond to one of +! the following tasks: +! +! 1. approximate solution of a linear system +! +! A*Y = X, +! +! by using the L and U factors computed with an ILU (incomplete LU) factorization +! of A. In this case K = L*U ~ A, alpha = 1 and beta = 0. The factors L and U +! (and the matrix A) are either distributed and block-diagonal or replicated. +! +! 2. Solution of a linear system +! +! A*Y = X, +! +! by using the L and U factors computed with a LU factorization of A. In this +! case K = L*U = A, alpha = 1 and beta = 0. The LU factorization is performed +! by one of the following auxiliary pakages: +! a. UMFPACK, +! b. SuperLU, +! c. SuperLU_Dist. +! In the cases a. and b., the factors L and U (and the matrix A) are either +! distributed and block diagonal) or replicated; in the case c., L, U (and A) +! are distributed. +! +! This routine is used by mld_ssub_aply, to apply a 'base' block-Jacobi or +! Additive Schwarz (AS) preconditioner at any level of a multilevel preconditioner, +! or a block-Jacobi or LU or ILU solver at the coarsest level of a multilevel +! preconditioner. +! +! +! Arguments: +! +! alpha - real(psb_spk_), input. +! The scalar alpha. +! prec - type(mld_sbaseprec_type), input. +! The 'base preconditioner' data structure containing the local +! part of the L and U factors of the matrix A. +! x - real(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - real(psb_spk_), input. +! The scalar beta. +! y - real(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned or 'inverted'. +! trans - character(len=1), input. +! If trans='N','n' then op(K^(-1)) = K^(-1); +! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). +! If prec%iprcparm(smooth_sweeps_) > 1, the value of trans provided +! in input is ignored. +! work - real(psb_spk_), dimension (:), target. +! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). +! info - integer, output. +! Error code. +! +subroutine mld_ssub_solve(alpha,prec,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_ssub_solve + + implicit none + + ! Arguments + type(psb_desc_type), intent(in) :: desc_data + type(mld_sbaseprc_type), intent(in) :: prec + real(psb_spk_),intent(in) :: 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, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act + character(len=20) :: name + character :: trans_ + + interface + subroutine mld_sumf_solve(flag,m,x,b,n,ptr,info) + use psb_base_mod + integer, intent(in) :: flag,m,n,ptr + integer, intent(out) :: info + real(psb_spk_), intent(in) :: b(*) + real(psb_spk_), intent(inout) :: x(*) + end subroutine mld_sumf_solve + end interface + + name='mld_ssub_solve' + info = 0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + + + select case(prec%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + ! + ! Apply a block-Jacobi preconditioner with ILU(k)/MILU(k)/ILU(k,t) + ! factorization of the blocks (distributed matrix) or approximately + ! solve a system through ILU(k)/MILU(k)/ILU(k,t) (replicated matrix). + ! + + select case(trans_) + case('N') + + call psb_spsm(sone,prec%av(mld_l_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=prec%d,choice=psb_none_,work=aux) + if (info == 0) call psb_spsm(alpha,prec%av(mld_u_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_, work=aux) + + case('T','C') + call psb_spsm(sone,prec%av(mld_u_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=prec%d,choice=psb_none_,work=aux) + if (info == 0) call psb_spsm(alpha,prec%av(mld_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_,work=aux) + case default + call psb_errpush(4001,name,a_err='Invalid TRANS in ILU subsolve') + goto 9999 + end select + + case(mld_slu_) + ! + ! Apply a block-Jacobi preconditioner with LU factorization of the + ! blocks (distributed matrix) or approximately solve a local linear + ! system through LU (replicated matrix). The SuperLU package is used + ! to apply the LU factorization in both cases. + ! + + ww(1:n_row) = x(1:n_row) + + select case(trans_) + case('N') + call mld_sslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) + case('T','C') + call mld_sslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) + case default + call psb_errpush(4001,name,a_err='Invalid TRANS in SLU subsolve') + goto 9999 + end select + + if (info ==0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + case(mld_sludist_) + ! + ! Solve a distributed linear system with the LU factorization. + ! The SuperLU_DIST package is used. + ! + + ww(1:n_row) = x(1:n_row) + + select case(trans_) + case('N') + call mld_ssludist_solve(0,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) + case('T','C') + call mld_ssludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) + case default + call psb_errpush(4001,name,a_err='Invalid TRANS in SLUDist subsolve') + goto 9999 + end select + + if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + case (mld_umf_) + ! + ! Apply a block-Jacobi preconditioner with LU factorization of the + ! blocks (distributed matrix) or approximately solve a local linear + ! system through LU (replicated matrix). The UMFPACK package is used + ! to apply the LU factorization in both cases. + ! + + select case(trans_) + case('N') + call mld_sumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) + case('T','C') + call mld_sumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) + case default + call psb_errpush(4001,name,a_err='Invalid TRANS in UMF subsolve') + goto 9999 + end select + + if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + case default + call psb_errpush(4001,name,a_err='Invalid mld_sub_solve_') + goto 9999 + + end select + + if (info /= 0) then + call psb_errpush(4001,name,a_err='Error in subsolve') + goto 9999 + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_ssub_solve + diff --git a/mlprec/mld_sumf_bld.f90 b/mlprec/mld_sumf_bld.f90 new file mode 100644 index 00000000..ee0b03d1 --- /dev/null +++ b/mlprec/mld_sumf_bld.f90 @@ -0,0 +1,138 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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: mld_sumf_bld.f90 +! +! Subroutine: mld_sumf_bld +! Version: real +! +! This routine computes the LU factorization of the local part of the matrix +! stored into a, by using UMFPACK. +! +! The matrix to be factorized is +! - either a submatrix of the distributed matrix corresponding to any level +! of a multilevel preconditioner, and its factorization is used to build +! the 'base preconditioner' corresponding to that level, +! - or a copy of the whole matrix corresponding to the coarsest level of +! a multilevel preconditioner, and its factorization is used to build +! the 'base preconditioner' corresponding to the coarsest level. +! +! The data structures allocated by UMFPACK to compute the symbolic and the +! numeric factorization are pointed by p%iprcparm(mld_umf_symptr_) and +! p%iprcparm(mld_umf_numptr_). +! +! +! Arguments: +! a - type(psb_sspmat_type), input/output. +! The sparse matrix structure containing the local submatrix +! to be factorized. Note that a is intent(inout), and not only +! intent(in), since the row and column indices of the matrix +! stored in a are shifted by -1, and then again by +1, by the +! routine mld_sumf_fact, which is an interface to the UMFPACK +! C code performing the factorization. +! desc_a - type(psb_desc_type), input. +! The communication descriptor associated to a. +! p - type(mld_sbaseprc_type), input/output. +! The 'base preconditioner' data structure containing the pointers, +! p%iprcparm(mld_umf_symptr_) and p%iprcparm(mld_umf_numptr_), +! to the data structures used by UMFPACK for computing the LU +! factorization. +! info - integer, output. +! Error code. +! +subroutine mld_sumf_bld(a,desc_a,p,info) + + use psb_base_mod + use mld_inner_mod, mld_protect_name => mld_sumf_bld + + implicit none + +! Arguments + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(mld_sbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: nzt,ictxt,me,np,err_act + integer :: i_err(5) + character(len=20) :: name + + info=0 + name='mld_sumf_bld' + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + if (psb_toupper(a%fida) /= 'CSC') then + info=135 + call psb_errpush(info,name,a_err=a%fida) + goto 9999 + endif + + nzt = psb_sp_get_nnzeros(a) + + ! + ! Compute the LU factorization + ! + call mld_sumf_fact(a%m,nzt,& + & a%aspk,a%ia1,a%ia2,& + & p%iprcparm(mld_umf_symptr_),p%iprcparm(mld_umf_numptr_),info) + + if (info /= 0) then + i_err(1) = info + info=4110 + call psb_errpush(info,name,a_err='mld_umf_fact',i_err=i_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine mld_sumf_bld + + + diff --git a/mlprec/mld_sumf_interface.c b/mlprec/mld_sumf_interface.c new file mode 100644 index 00000000..39b9a254 --- /dev/null +++ b/mlprec/mld_sumf_interface.c @@ -0,0 +1,258 @@ +/* + * + * MLD2P4 version 1.0 + * MultiLevel Domain Decomposition Parallel Preconditioners Package + * based on PSBLAS (Parallel Sparse BLAS version 2.2) + * + * (C) Copyright 2008 + * + * Salvatore Filippone University of Rome Tor Vergata + * Alfredo Buttari University of Rome Tor Vergata + * Pasqua D'Ambra ICAR-CNR, Naples + * Daniela di Serafino Second University of Naples + * + * 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 MLD2P4 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 MLD2P4 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: mld_umf_interface.c + * + * Functions: mld_sumf_fact_, mld_sumf_solve_, mld_umf_free_. + * + * This file is an interface to the UMFPACK routines for sparse factorization and + * solve. It was obtained by adapting umfpack_di_demo under the original UMFPACK + * copyright terms reproduced below. + * + */ + +/* ===================== +UMFPACK Version 4.4 (Jan. 28, 2005), Copyright (c) 2005 by Timothy A. +Davis. All Rights Reserved. + +UMFPACK License: + + Your use or distribution of UMFPACK or any modified version of + UMFPACK implies that you agree to this License. + + THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY + EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. + + Permission is hereby granted to use or copy this program, provided + that the Copyright, this License, and the Availability of the original + version is retained on all copies. User documentation of any code that + uses UMFPACK or any modified version of UMFPACK code must cite the + Copyright, this License, the Availability note, and "Used by permission." + Permission to modify the code and to distribute modified code is granted, + provided the Copyright, this License, and the Availability note are + retained, and a notice that the code was modified is included. This + software was developed with support from the National Science Foundation, + and is provided to you free of charge. + +Availability: + + http://www.cise.ufl.edu/research/sparse/umfpack + +*/ + + + +#ifdef LowerUndescore +#define mld_sumf_fact_ mld_sumf_fact_ +#define mld_sumf_solve_ mld_sumf_solve_ +#define mld_sumf_free_ mld_sumf_free_ +#endif +#ifdef LowerDoubleUndescore +#define mld_sumf_fact_ mld_sumf_fact__ +#define mld_sumf_solve_ mld_sumf_solve__ +#define mld_sumf_free_ mld_sumf_free__ +#endif +#ifdef LowerCase +#define mld_sumf_fact_ mld_sumf_fact +#define mld_sumf_solve_ mld_sumf_solve +#define mld_sumf_free_ mld_sumf_free +#endif +#ifdef UpperUndescore +#define mld_sumf_fact_ MLD_SUMF_FACT_ +#define mld_sumf_solve_ MLD_SUMF_SOLVE_ +#define mld_sumf_free_ MLD_SUMF_FREE_ +#endif +#ifdef UpperFloatUndescore +#define mld_sumf_fact_ MLD_SUMF_FACT__ +#define mld_sumf_solve_ MLD_SUMF_SOLVE__ +#define mld_sumf_free_ MLD_SUMF_FREE__ +#endif +#ifdef UpperCase +#define mld_sumf_fact_ MLD_SUMF_FACT +#define mld_sumf_solve_ MLD_SUMF_SOLVE +#define mld_sumf_free_ MLD_SUMF_FREE +#endif + + +#include +/* Currently no single precision version in UMFPACK */ +#ifdef Have_UMF_ +#undef Have_UMF_ +#endif + +#ifdef Have_UMF_ +#include "umfpack.h" +#endif + +#ifdef Ptr64Bits +typedef long long fptr; +#else +typedef int fptr; /* 32-bit by default */ +#endif + +void +mld_sumf_fact_(int *n, int *nnz, + float *values, int *rowind, int *colptr, +#ifdef Have_UMF_ + fptr *symptr, + fptr *numptr, + +#else + void *symptr, + void *numptr, +#endif + int *info) + +{ + +#ifdef Have_UMF_ + float Info [UMFPACK_INFO], Control [UMFPACK_CONTROL]; + void *Symbolic, *Numeric ; + int i; + + + umfpack_di_defaults(Control); + + for (i = 0; i <= *n; ++i) --colptr[i]; + for (i = 0; i < *nnz; ++i) --rowind[i]; + *info = umfpack_di_symbolic (*n, *n, colptr, rowind, values, &Symbolic, + Control, Info); + + + if ( *info == UMFPACK_OK ) { + *info = 0; + } else { + printf("umfpack_di_symbolic() error returns INFO= %d\n", *info); + *info = -11; + *numptr = (fptr) NULL; + return; + } + + *symptr = (fptr) Symbolic; + + *info = umfpack_di_numeric (colptr, rowind, values, Symbolic, &Numeric, + Control, Info) ; + + + if ( *info == UMFPACK_OK ) { + *info = 0; + *numptr = (fptr) Numeric; + } else { + printf("umfpack_di_numeric() error returns INFO= %d\n", *info); + *info = -12; + *numptr = (fptr) NULL; + } + + for (i = 0; i <= *n; ++i) ++colptr[i]; + for (i = 0; i < *nnz; ++i) ++rowind[i]; +#else + fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + +void +mld_sumf_solve_(int *itrans, int *n, + float *x, float *b, int *ldb, +#ifdef Have_UMF_ + fptr *numptr, + +#else + void *numptr, +#endif + int *info) + +{ +#ifdef Have_UMF_ + float Info [UMFPACK_INFO], Control [UMFPACK_CONTROL]; + void *Symbolic, *Numeric ; + int i,trans; + + + umfpack_di_defaults(Control); + Control[UMFPACK_IRSTEP]=0; + + + if (*itrans == 0) { + trans = UMFPACK_A; + } else if (*itrans ==1) { + trans = UMFPACK_At; + } else { + trans = UMFPACK_A; + } + + *info = umfpack_di_solve(trans,NULL,NULL,NULL, + x,b,(void *) *numptr,Control,Info); + +#else + fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif + +} + + +void +mld_sumf_free_( +#ifdef Have_UMF_ + fptr *symptr, + fptr *numptr, + +#else + void *symptr, + void *numptr, +#endif + int *info) + +{ +#ifdef Have_UMF_ + void *Symbolic, *Numeric ; + Symbolic = (void *) *symptr; + Numeric = (void *) *numptr; + + umfpack_di_free_numeric(&Numeric); + umfpack_di_free_symbolic(&Symbolic); + *info=0; +#else + fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n"); + *info=-1; +#endif +} + + diff --git a/mlprec/mld_zilu0_fact.f90 b/mlprec/mld_zilu0_fact.f90 index 68e7cd46..82382058 100644 --- a/mlprec/mld_zilu0_fact.f90 +++ b/mlprec/mld_zilu0_fact.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -! File: mld_dilu0_fact.f90 +! File: mld_zilu0_fact.f90 ! ! Subroutine: mld_zilu0_fact ! Version: complex diff --git a/mlprec/mld_zmlprec_aply.f90 b/mlprec/mld_zmlprec_aply.f90 index e2dd552f..70749507 100644 --- a/mlprec/mld_zmlprec_aply.f90 +++ b/mlprec/mld_zmlprec_aply.f90 @@ -415,7 +415,7 @@ contains if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/size(x)+size(y),0,0,0,0/),& - & a_err='real(psb_dpk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -444,7 +444,7 @@ contains if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),& - & a_err='real(psb_dpk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -677,7 +677,7 @@ contains if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& - & a_err='real(psb_dpk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -729,7 +729,7 @@ contains if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& - & a_err='real(psb_dpk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -989,7 +989,7 @@ contains if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& - & a_err='real(psb_dpk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -1266,7 +1266,7 @@ contains if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& - & a_err='real(psb_dpk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -1316,7 +1316,7 @@ contains if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),& - & a_err='real(psb_dpk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if diff --git a/mlprec/mld_zmlprec_bld.f90 b/mlprec/mld_zmlprec_bld.f90 index 9b7e9d2f..57af6de3 100644 --- a/mlprec/mld_zmlprec_bld.f90 +++ b/mlprec/mld_zmlprec_bld.f90 @@ -78,7 +78,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info) character(len=20) :: name integer :: ictxt, np, me, err_act - name='psb_zmlprec_bld' + name='mld_zmlprec_bld' if (psb_get_errstatus().ne.0) return call psb_erractionsave(err_act) info = 0 diff --git a/mlprec/mld_zprecset.f90 b/mlprec/mld_zprecset.f90 index d9e559eb..e999b2a6 100644 --- a/mlprec/mld_zprecset.f90 +++ b/mlprec/mld_zprecset.f90 @@ -47,7 +47,7 @@ ! For the multilevel preconditioners, the levels are numbered in increasing ! order starting from the finest one, i.e. level 1 is the finest level. ! -! To set character and real parameters, see mld_zprecsetc and mld_zprecsetd, +! To set character and real parameters, see mld_zprecsetc and mld_zprecsetr, ! respectively. ! ! @@ -249,7 +249,7 @@ end subroutine mld_zprecseti ! For the multilevel preconditioners, the levels are numbered in increasing ! order starting from the finest one, i.e. level 1 is the finest level. ! -! To set integer and real parameters, see mld_zprecseti and mld_zprecsetd, +! To set integer and real parameters, see mld_zprecseti and mld_zprecsetr, ! respectively. ! ! @@ -501,7 +501,7 @@ end subroutine mld_zprecsetc ! -! Subroutine: mld_zprecsetd +! Subroutine: mld_zprecsetr ! Version: complex ! ! This routine sets the real parameters defining the preconditioner. More @@ -532,10 +532,10 @@ end subroutine mld_zprecsetc ! If nlev is not present, the parameter identified by 'what' ! is set at all the appropriate levels. ! -subroutine mld_zprecsetd(p,what,val,info,ilev) +subroutine mld_zprecsetr(p,what,val,info,ilev) use psb_base_mod - use mld_prec_mod, mld_protect_name => mld_zprecsetd + use mld_prec_mod, mld_protect_name => mld_zprecsetr implicit none @@ -634,4 +634,4 @@ subroutine mld_zprecsetd(p,what,val,info,ilev) endif -end subroutine mld_zprecsetd +end subroutine mld_zprecsetr diff --git a/test/fileread/Makefile b/test/fileread/Makefile index c999dd15..0b2ec51c 100644 --- a/test/fileread/Makefile +++ b/test/fileread/Makefile @@ -7,12 +7,15 @@ PSBLAS_LIB= -L$(PSBDIR) -lpsb_util -lpsb_base FINCLUDES=$(FMFLAG). $(FMFLAG)$(MLDLIBDIR) $(FMFLAG)$(PSBDIR) $(FIFLAG). DFOBJS=df_bench.o -DFSOBJS=df_sample.o +DFSOBJS=df_sample.o data_input.o +SFSOBJS=sf_sample.o data_input.o +CFSOBJS=cf_sample.o data_input.o +ZFSOBJS=zf_sample.o data_input.o ZFOBJS=zf_bench.o EXEDIR=./runs -all: df_bench zf_bench df_sample +all: df_bench zf_bench sf_sample df_sample cf_sample zf_sample df_bench: $(DFOBJS) $(F90LINK) $(LINKOPT) $(DFOBJS) -o df_bench \ @@ -24,17 +27,36 @@ df_sample: $(DFSOBJS) $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv df_sample $(EXEDIR) +sf_sample: $(SFSOBJS) + $(F90LINK) $(LINKOPT) $(SFSOBJS) -o sf_sample \ + $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) + /bin/mv sf_sample $(EXEDIR) + +cf_sample: $(CFSOBJS) + $(F90LINK) $(LINKOPT) $(CFSOBJS) -o cf_sample \ + $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) + /bin/mv cf_sample $(EXEDIR) + +zf_sample: $(ZFSOBJS) + $(F90LINK) $(LINKOPT) $(ZFSOBJS) -o zf_sample \ + $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) + /bin/mv zf_sample $(EXEDIR) + zf_bench: $(ZFOBJS) $(F90LINK) $(LINKOPT) $(ZFOBJS) -o zf_bench \ $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv zf_bench $(EXEDIR) +sf_sample.o: data_input.o +df_sample.o: data_input.o +cf_sample.o: data_input.o +zf_sample.o: data_input.o .f90.o: $(MPF90) $(F90COPT) $(FINCLUDES) -c $< clean: - /bin/rm -f $(DFOBJS) $(ZFOBJS) \ + /bin/rm -f $(DFOBJS) $(ZFOBJS) $(SFSOBJS) $(DFSOBJS) \ *$(.mod) $(EXEDIR)/df_bench $(EXEDIR)/zf_bench lib: diff --git a/test/fileread/cf_sample.f90 b/test/fileread/cf_sample.f90 new file mode 100644 index 00000000..162b1b55 --- /dev/null +++ b/test/fileread/cf_sample.f90 @@ -0,0 +1,454 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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. +!!$ +!!$ +program cf_sample + use psb_base_mod + use mld_prec_mod + use psb_krylov_mod + use psb_util_mod + use data_input + implicit none + + + ! input parameters + character(len=40) :: kmethd, mtrx_file, rhs_file + type precdata + character(len=20) :: descr ! verbose description of the prec + character(len=10) :: prec ! overall prectype + integer :: novr ! number of overlap layers + character(len=16) :: restr ! restriction over application of as + character(len=16) :: prol ! prolongation over application of as + character(len=16) :: solve ! Factorization type: ILU, SuperLU, UMFPACK. + integer :: fill1 ! Fill-in for factorization 1 + real(psb_spk_) :: thr1 ! Threshold for fact. 1 ILU(T) + integer :: nlev ! Number of levels in multilevel prec. + character(len=16) :: aggrkind ! smoothed/raw aggregatin + character(len=16) :: aggr_alg ! local or global aggregation + character(len=16) :: mltype ! additive or multiplicative 2nd level prec + character(len=16) :: smthpos ! side: pre, post, both smoothing + character(len=16) :: cmat ! coarse mat + character(len=16) :: csolve ! Factorization type: ILU, SuperLU, UMFPACK. + integer :: cfill ! Fill-in for factorization 1 + real(psb_spk_) :: cthres ! Threshold for fact. 1 ILU(T) + integer :: cjswp ! Jacobi sweeps + real(psb_spk_) :: omega ! smoother omega + end type precdata + type(precdata) :: prec_choice + + ! sparse matrices + type(psb_cspmat_type) :: a, aux_a + + ! preconditioner data + type(mld_cprec_type) :: prec + + ! dense matrices + complex(psb_spk_), allocatable, target :: aux_b(:,:), d(:) + complex(psb_spk_), allocatable , save :: b_col(:), x_col(:), r_col(:), & + & x_col_glob(:), r_col_glob(:) + complex(psb_spk_), pointer :: b_col_glob(:) + + ! communications data structure + type(psb_desc_type):: desc_a + + integer :: ictxt, iam, np + + ! solver paramters + integer :: iter, itmax, ierr, itrace, ircode, ipart,& + & methd, istopc, irst,amatsize,precsize,descsize, nlv + real(psb_spk_) :: err, eps + + character(len=5) :: afmt + character(len=20) :: name + integer :: iparm(20) + + ! other variables + integer :: i,info,j,m_problem + integer :: internal, m,ii,nnzero + real(psb_dpk_) :: t1, t2, tprec + real(psb_spk_) :: r_amax, b_amax, scale,resmx,resmxp + integer :: nrhs, nrow, n_row, dim, nv, ne + integer, allocatable :: ivg(:), ipv(:) + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + + + name='sf_sample' + if(psb_get_errstatus() /= 0) goto 9999 + info=0 + call psb_set_errverbosity(2) + ! + ! get parameters + ! + call get_parms(ictxt,mtrx_file,rhs_file,kmethd,& + & prec_choice,ipart,afmt,istopc,itmax,itrace,irst,eps) + + call psb_barrier(ictxt) + t1 = psb_wtime() + ! read the input matrix to be processed and (possibly) the rhs + nrhs = 1 + + if (iam==psb_root_) then + call read_mat(mtrx_file, aux_a, ictxt) + + m_problem = aux_a%m + call psb_bcast(ictxt,m_problem) + + if(rhs_file /= 'NONE') then + ! reading an rhs + call read_rhs(rhs_file,aux_b,ictxt) + end if + + if (psb_size(aux_b,dim=1)==m_problem) then + ! if any rhs were present, broadcast the first one + write(0,'("Ok, got an rhs ")') + b_col_glob =>aux_b(:,1) + else + write(*,'("Generating an rhs...")') + write(*,'(" ")') + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + + b_col_glob => aux_b(:,1) + do i=1, m_problem + b_col_glob(i) = 1.0 + enddo + endif + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + else + call psb_bcast(ictxt,m_problem) + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + b_col_glob =>aux_b(:,1) + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + end if + + ! switch over different partition types + if (ipart == 0) then + call psb_barrier(ictxt) + if (iam==psb_root_) write(*,'("Partition type: block")') + allocate(ivg(m_problem),ipv(np)) + do i=1,m_problem + call part_block(i,m_problem,np,ipv,nv) + ivg(i) = ipv(1) + enddo + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else if (ipart == 2) then + if (iam==psb_root_) then + write(*,'("Partition type: graph")') + write(*,'(" ")') + ! write(0,'("Build type: graph")') + call build_mtpart(aux_a%m,aux_a%fida,aux_a%ia1,aux_a%ia2,np) + endif + call psb_barrier(ictxt) + call distr_mtpart(psb_root_,ictxt) + call getv_mtpart(ivg) + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else + if (iam==psb_root_) write(*,'("Partition type: block")') + call psb_matdist(aux_a, a, part_block, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + end if + + call psb_geall(x_col,desc_a,info) + x_col(:) =0.0 + call psb_geasb(x_col,desc_a,info) + call psb_geall(r_col,desc_a,info) + r_col(:) =0.0 + call psb_geasb(r_col,desc_a,info) + t2 = psb_wtime() - t1 + + + call psb_amx(ictxt, t2) + + if (iam==psb_root_) then + write(*,'(" ")') + write(*,'("Time to read and partition matrix : ",es10.4)')t2 + write(*,'(" ")') + write(*,*) 'Preconditioner: ',prec_choice%descr + end if + + ! + + if (psb_toupper(prec_choice%prec) =='ML') then + nlv = prec_choice%nlev + else + nlv = 1 + end if + call mld_precinit(prec,prec_choice%prec,info,nlev=nlv) + call mld_precset(prec,mld_n_ovr_,prec_choice%novr,info) + call mld_precset(prec,mld_sub_restr_,prec_choice%restr,info) + call mld_precset(prec,mld_sub_prol_,prec_choice%prol,info) + call mld_precset(prec,mld_sub_solve_,prec_choice%solve,info) + call mld_precset(prec,mld_sub_fill_in_,prec_choice%fill1,info) + call mld_precset(prec,mld_fact_thrs_,prec_choice%thr1,info) + if (psb_toupper(prec_choice%prec) =='ML') then + call mld_precset(prec,mld_aggr_kind_,prec_choice%aggrkind,info) + call mld_precset(prec,mld_aggr_alg_,prec_choice%aggr_alg,info) + call mld_precset(prec,mld_ml_type_,prec_choice%mltype,info) + call mld_precset(prec,mld_ml_type_,prec_choice%mltype,info) + call mld_precset(prec,mld_smooth_pos_,prec_choice%smthpos,info) + call mld_precset(prec,mld_coarse_mat_,prec_choice%cmat,info) + call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info) + call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv) + call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv) + call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) + call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) + if (prec_choice%omega>=0.0) then + call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv) + end if + end if + + ! building the preconditioner + t1 = psb_wtime() + call mld_precbld(a,desc_a,prec,info) + tprec = psb_wtime()-t1 + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_precbld') + goto 9999 + end if + + + call psb_amx(ictxt, tprec) + + if(iam==psb_root_) then + write(*,'("Preconditioner time: ",es10.4)')tprec + write(*,'(" ")') + end if + + iparm = 0 + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + + call psb_amx(ictxt,t2) + call psb_geaxpby(cone,b_col,czero,r_col,desc_a,info) + call psb_spmm(-cone,a,x_col,cone,r_col,desc_a,info) + call psb_genrm2s(resmx,r_col,desc_a,info) + call psb_geamaxs(resmxp,r_col,desc_a,info) + + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + precsize = mld_sizeof(prec) + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam==psb_root_) then + call mld_prec_descr(6,prec) + write(*,'("Matrix: ",a)')mtrx_file + write(*,'("Computed solution on ",i8," processors")')np + write(*,'("Iterations to convergence : ",i6)')iter + write(*,'("Error estimate on exit : ",es10.4)')err + write(*,'("Time to buil prec. : ",es10.4)')tprec + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/(iter) + write(*,'("Total time : ",es10.4)')t2+tprec + write(*,'("Residual norm 2 : ",es10.4)')resmx + write(*,'("Residual norm inf : ",es10.4)')resmxp + write(*,'("Total memory occupation for A : ",i10)')amatsize + write(*,'("Total memory occupation for DESC_A : ",i10)')descsize + write(*,'("Total memory occupation for PREC : ",i10)')precsize + end if + + allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr) + if (ierr /= 0) then + write(0,*) 'allocation error: no data collection' + else + call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) + call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) + if (iam==psb_root_) then + write(0,'(" ")') + write(0,'("Saving x on file")') + write(20,*) 'matrix: ',mtrx_file + write(20,*) 'computed solution on ',np,' processors.' + write(20,*) 'iterations to convergence: ',iter + write(20,*) 'error estimate (infinity norm) on exit:', & + & ' ||r||/(||a||||x||+||b||) = ',err + write(20,*) 'max residual = ',resmx, resmxp + write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)' + do i=1,m_problem + write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i) + enddo + end if + end if +998 format(i8,4(2x,g20.14)) +993 format(i6,4(1x,e12.6)) + + + call psb_gefree(b_col, desc_a,info) + call psb_gefree(x_col, desc_a,info) + call psb_spfree(a, desc_a,info) + call mld_precfree(prec,info) + call psb_cdfree(desc_a,info) + +9999 continue + if(info /= 0) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(icontxt,mtrx,rhs,kmethd,& + & prec, ipart,afmt,istopc,itmax,itrace,irst,eps) + + use psb_base_mod + implicit none + + integer :: icontxt + character(len=*) :: kmethd, mtrx, rhs, afmt + type(precdata) :: prec + integer :: iret, istopc,itmax,itrace, ipart, irst + real(psb_spk_) :: eps, omega,thr1,thr2 + integer :: iam, nm, np, i + + call psb_info(icontxt,iam,np) + + if (iam==psb_root_) then + ! read input parameters + call read_data(mtrx,5) + call read_data(rhs,5) + call read_data(kmethd,5) + call read_data(afmt,5) + call read_data(ipart,5) + call read_data(istopc,5) + call read_data(itmax,5) + call read_data(itrace,5) + call read_data(irst,5) + call read_data(eps,5) + call read_data(prec%descr,5) ! verbose description of the prec + call read_data(prec%prec,5) ! overall prectype + call read_data(prec%novr,5) ! number of overlap layers + call read_data(prec%restr,5) ! restriction over application of as + call read_data(prec%prol,5) ! prolongation over application of as + call read_data(prec%solve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%fill1,5) ! Fill-in for factorization 1 + call read_data(prec%thr1,5) ! Threshold for fact. 1 ILU(T) + if (psb_toupper(prec%prec) == 'ML') then + call read_data(prec%nlev,5) ! Number of levels in multilevel prec. + call read_data(prec%aggrkind,5) ! smoothed/raw aggregatin + call read_data(prec%aggr_alg,5) ! local or global aggregation + call read_data(prec%mltype,5) ! additive or multiplicative 2nd level prec + call read_data(prec%smthpos,5) ! side: pre, post, both smoothing + call read_data(prec%cmat,5) ! coarse mat + call read_data(prec%csolve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%cfill,5) ! Fill-in for factorization 1 + call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T) + call read_data(prec%cjswp,5) ! Jacobi sweeps + call read_data(prec%omega,5) ! smoother omega + end if + end if + + call psb_bcast(icontxt,mtrx) + call psb_bcast(icontxt,rhs) + call psb_bcast(icontxt,kmethd) + call psb_bcast(icontxt,afmt) + call psb_bcast(icontxt,ipart) + call psb_bcast(icontxt,istopc) + call psb_bcast(icontxt,itmax) + call psb_bcast(icontxt,itrace) + call psb_bcast(icontxt,irst) + call psb_bcast(icontxt,eps) + + call psb_bcast(icontxt,prec%descr) ! verbose description of the prec + call psb_bcast(icontxt,prec%prec) ! overall prectype + call psb_bcast(icontxt,prec%novr) ! number of overlap layers + call psb_bcast(icontxt,prec%restr) ! restriction over application of as + call psb_bcast(icontxt,prec%prol) ! prolongation over application of as + call psb_bcast(icontxt,prec%solve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(icontxt,prec%fill1) ! Fill-in for factorization 1 + call psb_bcast(icontxt,prec%thr1) ! Threshold for fact. 1 ILU(T) + if (psb_toupper(prec%prec) == 'ML') then + call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. + call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin + call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec + call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing + call psb_bcast(icontxt,prec%cmat) ! coarse mat + call psb_bcast(icontxt,prec%csolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(icontxt,prec%cfill) ! Fill-in for factorization 1 + call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T) + call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps + call psb_bcast(icontxt,prec%omega) ! smoother omega + end if + + end subroutine get_parms + subroutine pr_usage(iout) + integer iout + write(iout, *) ' number of parameters is incorrect!' + write(iout, *) ' use: hb_sample mtrx_file methd prec [ptype & + &itmax istopc itrace]' + write(iout, *) ' where:' + write(iout, *) ' mtrx_file is stored in hb format' + write(iout, *) ' methd may be: cgstab ' + write(iout, *) ' itmax max iterations [500] ' + write(iout, *) ' istopc stopping criterion [1] ' + write(iout, *) ' itrace 0 (no tracing, default) or ' + write(iout, *) ' >= 0 do tracing every itrace' + write(iout, *) ' iterations ' + write(iout, *) ' prec may be: ilu diagsc none' + write(iout, *) ' ptype partition strategy default 0' + write(iout, *) ' 0: block partition ' + end subroutine pr_usage +end program cf_sample + + + + + diff --git a/test/fileread/data_input.f90 b/test/fileread/data_input.f90 new file mode 100644 index 00000000..32aae9fb --- /dev/null +++ b/test/fileread/data_input.f90 @@ -0,0 +1,91 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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 data_input + + interface read_data + module procedure read_char, read_int,& + & read_double, read_single + end interface read_data + +contains + + subroutine read_char(val,file) + character(len=*), intent(out) :: val + integer, intent(in) :: file + character(len=1024) :: charbuf + integer :: idx + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,"!") + read(charbuf(1:idx-1),'(a)') val + end subroutine read_char + subroutine read_int(val,file) + integer, intent(out) :: val + integer, intent(in) :: file + character(len=1024) :: charbuf + integer :: idx + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,"!") + read(charbuf(1:idx-1),*) val + end subroutine read_int + subroutine read_single(val,file) + use psb_base_mod + real(psb_spk_), intent(out) :: val + integer, intent(in) :: file + character(len=1024) :: charbuf + integer :: idx + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,"!") + read(charbuf(1:idx-1),*) val + end subroutine read_single + subroutine read_double(val,file) + use psb_base_mod + real(psb_dpk_), intent(out) :: val + integer, intent(in) :: file + character(len=1024) :: charbuf + integer :: idx + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,"!") + read(charbuf(1:idx-1),*) val + end subroutine read_double +end module data_input + diff --git a/test/fileread/df_sample.f90 b/test/fileread/df_sample.f90 index e1e0d6eb..a1d350a7 100644 --- a/test/fileread/df_sample.f90 +++ b/test/fileread/df_sample.f90 @@ -36,52 +36,6 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ - -module data_input - - interface read_data - module procedure read_char, read_int, read_double - end interface read_data - -contains - - subroutine read_char(val,file) - character(len=*), intent(out) :: val - integer, intent(in) :: file - character(len=1024) :: charbuf - integer :: idx - read(file,'(a)')charbuf - charbuf = adjustl(charbuf) - idx=index(charbuf,"!") - read(charbuf(1:idx-1),'(a)') val -!!$ write(0,*) 'read_char got value: "',val,'"' - end subroutine read_char - subroutine read_int(val,file) - integer, intent(out) :: val - integer, intent(in) :: file - character(len=1024) :: charbuf - integer :: idx - read(file,'(a)')charbuf - charbuf = adjustl(charbuf) - idx=index(charbuf,"!") - read(charbuf(1:idx-1),*) val -!!$ write(0,*) 'read_int got value: ',val - end subroutine read_int - subroutine read_double(val,file) - use psb_base_mod - real(psb_dpk_), intent(out) :: val - integer, intent(in) :: file - character(len=1024) :: charbuf - integer :: idx - read(file,'(a)')charbuf - charbuf = adjustl(charbuf) - idx=index(charbuf,"!") - read(charbuf(1:idx-1),*) val -!!$ write(0,*) 'read_double got value: ',val - end subroutine read_double -end module data_input - - program df_sample use psb_base_mod use mld_prec_mod @@ -336,17 +290,17 @@ program df_sample call mld_prec_descr(6,prec) write(*,'("Matrix: ",a)')mtrx_file write(*,'("Computed solution on ",i8," processors")')np - write(*,'("Iterations to convergence: ",i6)')iter - write(*,'("Error estimate on exit: ",f7.2)')err - write(*,'("Time to buil prec. : ",es10.4)')tprec - write(*,'("Time to solve matrix : ",es10.4)')t2 - write(*,'("Time per iteration : ",es10.4)')t2/(iter) - write(*,'("Total time : ",es10.4)')t2+tprec - write(*,'("Residual norm 2 = ",es10.4)')resmx - write(*,'("Residual norm inf = ",es10.4)')resmxp - write(*,'("Total memory occupation for A: ",i10)')amatsize - write(*,'("Total memory occupation for DESC_A: ",i10)')descsize - write(*,'("Total memory occupation for PREC: ",i10)')precsize + write(*,'("Iterations to convergence : ",i6)')iter + write(*,'("Error estimate on exit : ",es10.4)')err + write(*,'("Time to buil prec. : ",es10.4)')tprec + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/(iter) + write(*,'("Total time : ",es10.4)')t2+tprec + write(*,'("Residual norm 2 : ",es10.4)')resmx + write(*,'("Residual norm inf : ",es10.4)')resmxp + write(*,'("Total memory occupation for A : ",i10)')amatsize + write(*,'("Total memory occupation for DESC_A : ",i10)')descsize + write(*,'("Total memory occupation for PREC : ",i10)')precsize end if allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr) @@ -493,8 +447,3 @@ contains write(iout, *) ' 0: block partition ' end subroutine pr_usage end program df_sample - - - - - diff --git a/test/fileread/runs/cfs.inp b/test/fileread/runs/cfs.inp new file mode 100644 index 00000000..b8df9d7c --- /dev/null +++ b/test/fileread/runs/cfs.inp @@ -0,0 +1,29 @@ +qc2534.mtx !This (and others) from: http://math.nist.gov/MatrixMarket/ or +NONE !http://www.cise.ufl.edu/research/sparse/matrices/index.html +BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CSR ! Storage format CSR COO JAD +0 ! IPART: Partition method 0: BLK 2: graph (with Metis) +2 ! ISTOPC +01000 ! ITMAX +01 ! ITRACE +30 ! IRST (restart for RGMRES and BiCGSTABL) +1.d-5 ! EPS +3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) +ML ! Preconditioner NONE DIAG BJAC AS ML +0 ! Number of overlap layers for AS preconditioner at finest level +HALO ! Restriction operator NONE HALO +NONE ! Prolongation operator NONE SUM AVG +ILU ! Subdomain solver ILU MILU ILUT UMF SLU +1 ! Level-set N for ILU(N) +1.d-4 ! Threshold T for ILU(T,P) +3 ! Number of levels in a multilevel preconditioner +SMOOTH ! Kind of aggregation: RAW, SMOOTH +DEC ! Type of aggregation DEC SYMDEC GLB +MULT ! Type of multilevel correction: ADD MULT +POST ! Side of multiplicative correction PRE POST BOTH (ignored for ADD) +DIST ! Coarse level: matrix distribution DIST REPL +ILU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST +0 ! Coarse level: Level-set N for ILU(N) +1.d-4 ! Coarse level: Threshold T for ILU(T,P) +4 ! Coarse level: Number of Jacobi sweeps +-1.0d0 ! Smoother Omega: if < 0 means library choice. diff --git a/test/fileread/runs/dfs.inp b/test/fileread/runs/dfs.inp index 778ae2df..2a9f9528 100644 --- a/test/fileread/runs/dfs.inp +++ b/test/fileread/runs/dfs.inp @@ -1,13 +1,13 @@ -thm1000x600.mtx ! young1r.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or -NONE ! rhs.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html +thm1000x600.mtx ! les_t4.mtx ! young1r.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or +NONE !les_t4.rhs ! rhs.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD -2 ! IPART: Partition method 0: BLK 2: graph (with Metis) +0 ! IPART: Partition method 0: BLK 2: graph (with Metis) 2 ! ISTOPC 01000 ! ITMAX --1 ! ITRACE +01 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) -1.d-6 ! EPS +1.d-5 ! EPS 3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) ML ! Preconditioner NONE DIAG BJAC AS ML 0 ! Number of overlap layers for AS preconditioner at finest level @@ -22,7 +22,7 @@ DEC ! Type of aggregation DEC SYMDEC GLB MULT ! Type of multilevel correction: ADD MULT POST ! Side of multiplicative correction PRE POST BOTH (ignored for ADD) DIST ! Coarse level: matrix distribution DIST REPL -UMF ! Coarse level: solver ILU ILUT UMF SLU SLUDIST +ILU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST 0 ! Coarse level: Level-set N for ILU(N) 1.d-4 ! Coarse level: Threshold T for ILU(T,P) 4 ! Coarse level: Number of Jacobi sweeps diff --git a/test/fileread/runs/sfs.inp b/test/fileread/runs/sfs.inp new file mode 100644 index 00000000..3fbcc92d --- /dev/null +++ b/test/fileread/runs/sfs.inp @@ -0,0 +1,29 @@ +thm1000x600.mtx ! les_t4.mtx ! young1r.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or +NONE !les_t4.rhs ! rhs.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html +RGMRES ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CSR ! Storage format CSR COO JAD +0 ! IPART: Partition method 0: BLK 2: graph (with Metis) +2 ! ISTOPC +01000 ! ITMAX +01 ! ITRACE +30 ! IRST (restart for RGMRES and BiCGSTABL) +1.d-5 ! EPS +3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) +ML ! Preconditioner NONE DIAG BJAC AS ML +0 ! Number of overlap layers for AS preconditioner at finest level +HALO ! Restriction operator NONE HALO +NONE ! Prolongation operator NONE SUM AVG +ILU ! Subdomain solver ILU MILU ILUT UMF SLU +1 ! Level-set N for ILU(N) +1.d-4 ! Threshold T for ILU(T,P) +3 ! Number of levels in a multilevel preconditioner +SMOOTH ! Kind of aggregation: RAW, SMOOTH +DEC ! Type of aggregation DEC SYMDEC GLB +MULT ! Type of multilevel correction: ADD MULT +POST ! Side of multiplicative correction PRE POST BOTH (ignored for ADD) +DIST ! Coarse level: matrix distribution DIST REPL +ILU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST +0 ! Coarse level: Level-set N for ILU(N) +1.d-4 ! Coarse level: Threshold T for ILU(T,P) +4 ! Coarse level: Number of Jacobi sweeps +-1.0d0 ! Smoother Omega: if < 0 means library choice. diff --git a/test/fileread/runs/zfs.inp b/test/fileread/runs/zfs.inp new file mode 100644 index 00000000..b8df9d7c --- /dev/null +++ b/test/fileread/runs/zfs.inp @@ -0,0 +1,29 @@ +qc2534.mtx !This (and others) from: http://math.nist.gov/MatrixMarket/ or +NONE !http://www.cise.ufl.edu/research/sparse/matrices/index.html +BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CSR ! Storage format CSR COO JAD +0 ! IPART: Partition method 0: BLK 2: graph (with Metis) +2 ! ISTOPC +01000 ! ITMAX +01 ! ITRACE +30 ! IRST (restart for RGMRES and BiCGSTABL) +1.d-5 ! EPS +3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) +ML ! Preconditioner NONE DIAG BJAC AS ML +0 ! Number of overlap layers for AS preconditioner at finest level +HALO ! Restriction operator NONE HALO +NONE ! Prolongation operator NONE SUM AVG +ILU ! Subdomain solver ILU MILU ILUT UMF SLU +1 ! Level-set N for ILU(N) +1.d-4 ! Threshold T for ILU(T,P) +3 ! Number of levels in a multilevel preconditioner +SMOOTH ! Kind of aggregation: RAW, SMOOTH +DEC ! Type of aggregation DEC SYMDEC GLB +MULT ! Type of multilevel correction: ADD MULT +POST ! Side of multiplicative correction PRE POST BOTH (ignored for ADD) +DIST ! Coarse level: matrix distribution DIST REPL +ILU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST +0 ! Coarse level: Level-set N for ILU(N) +1.d-4 ! Coarse level: Threshold T for ILU(T,P) +4 ! Coarse level: Number of Jacobi sweeps +-1.0d0 ! Smoother Omega: if < 0 means library choice. diff --git a/test/fileread/sf_sample.f90 b/test/fileread/sf_sample.f90 new file mode 100644 index 00000000..88ab6a0d --- /dev/null +++ b/test/fileread/sf_sample.f90 @@ -0,0 +1,454 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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. +!!$ +!!$ +program sf_sample + use psb_base_mod + use mld_prec_mod + use psb_krylov_mod + use psb_util_mod + use data_input + implicit none + + + ! input parameters + character(len=40) :: kmethd, mtrx_file, rhs_file + type precdata + character(len=20) :: descr ! verbose description of the prec + character(len=10) :: prec ! overall prectype + integer :: novr ! number of overlap layers + character(len=16) :: restr ! restriction over application of as + character(len=16) :: prol ! prolongation over application of as + character(len=16) :: solve ! Factorization type: ILU, SuperLU, UMFPACK. + integer :: fill1 ! Fill-in for factorization 1 + real(psb_spk_) :: thr1 ! Threshold for fact. 1 ILU(T) + integer :: nlev ! Number of levels in multilevel prec. + character(len=16) :: aggrkind ! smoothed/raw aggregatin + character(len=16) :: aggr_alg ! local or global aggregation + character(len=16) :: mltype ! additive or multiplicative 2nd level prec + character(len=16) :: smthpos ! side: pre, post, both smoothing + character(len=16) :: cmat ! coarse mat + character(len=16) :: csolve ! Factorization type: ILU, SuperLU, UMFPACK. + integer :: cfill ! Fill-in for factorization 1 + real(psb_spk_) :: cthres ! Threshold for fact. 1 ILU(T) + integer :: cjswp ! Jacobi sweeps + real(psb_spk_) :: omega ! smoother omega + end type precdata + type(precdata) :: prec_choice + + ! sparse matrices + type(psb_sspmat_type) :: a, aux_a + + ! preconditioner data + type(mld_sprec_type) :: prec + + ! dense matrices + real(psb_spk_), allocatable, target :: aux_b(:,:), d(:) + real(psb_spk_), allocatable , save :: b_col(:), x_col(:), r_col(:), & + & x_col_glob(:), r_col_glob(:) + real(psb_spk_), pointer :: b_col_glob(:) + + ! communications data structure + type(psb_desc_type):: desc_a + + integer :: ictxt, iam, np + + ! solver paramters + integer :: iter, itmax, ierr, itrace, ircode, ipart,& + & methd, istopc, irst,amatsize,precsize,descsize, nlv + real(psb_spk_) :: err, eps + + character(len=5) :: afmt + character(len=20) :: name + integer :: iparm(20) + + ! other variables + integer :: i,info,j,m_problem + integer :: internal, m,ii,nnzero + real(psb_dpk_) :: t1, t2, tprec + real(psb_spk_) :: r_amax, b_amax, scale,resmx,resmxp + integer :: nrhs, nrow, n_row, dim, nv, ne + integer, allocatable :: ivg(:), ipv(:) + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + + + name='sf_sample' + if(psb_get_errstatus() /= 0) goto 9999 + info=0 + call psb_set_errverbosity(2) + ! + ! get parameters + ! + call get_parms(ictxt,mtrx_file,rhs_file,kmethd,& + & prec_choice,ipart,afmt,istopc,itmax,itrace,irst,eps) + + call psb_barrier(ictxt) + t1 = psb_wtime() + ! read the input matrix to be processed and (possibly) the rhs + nrhs = 1 + + if (iam==psb_root_) then + call read_mat(mtrx_file, aux_a, ictxt) + + m_problem = aux_a%m + call psb_bcast(ictxt,m_problem) + + if(rhs_file /= 'NONE') then + ! reading an rhs + call read_rhs(rhs_file,aux_b,ictxt) + end if + + if (psb_size(aux_b,dim=1)==m_problem) then + ! if any rhs were present, broadcast the first one + write(0,'("Ok, got an rhs ")') + b_col_glob =>aux_b(:,1) + else + write(*,'("Generating an rhs...")') + write(*,'(" ")') + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + + b_col_glob => aux_b(:,1) + do i=1, m_problem + b_col_glob(i) = 1.0 + enddo + endif + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + else + call psb_bcast(ictxt,m_problem) + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + b_col_glob =>aux_b(:,1) + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + end if + + ! switch over different partition types + if (ipart == 0) then + call psb_barrier(ictxt) + if (iam==psb_root_) write(*,'("Partition type: block")') + allocate(ivg(m_problem),ipv(np)) + do i=1,m_problem + call part_block(i,m_problem,np,ipv,nv) + ivg(i) = ipv(1) + enddo + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else if (ipart == 2) then + if (iam==psb_root_) then + write(*,'("Partition type: graph")') + write(*,'(" ")') + ! write(0,'("Build type: graph")') + call build_mtpart(aux_a%m,aux_a%fida,aux_a%ia1,aux_a%ia2,np) + endif + call psb_barrier(ictxt) + call distr_mtpart(psb_root_,ictxt) + call getv_mtpart(ivg) + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else + if (iam==psb_root_) write(*,'("Partition type: block")') + call psb_matdist(aux_a, a, part_block, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + end if + + call psb_geall(x_col,desc_a,info) + x_col(:) =0.0 + call psb_geasb(x_col,desc_a,info) + call psb_geall(r_col,desc_a,info) + r_col(:) =0.0 + call psb_geasb(r_col,desc_a,info) + t2 = psb_wtime() - t1 + + + call psb_amx(ictxt, t2) + + if (iam==psb_root_) then + write(*,'(" ")') + write(*,'("Time to read and partition matrix : ",es10.4)')t2 + write(*,'(" ")') + write(*,*) 'Preconditioner: ',prec_choice%descr + end if + + ! + + if (psb_toupper(prec_choice%prec) =='ML') then + nlv = prec_choice%nlev + else + nlv = 1 + end if + call mld_precinit(prec,prec_choice%prec,info,nlev=nlv) + call mld_precset(prec,mld_n_ovr_,prec_choice%novr,info) + call mld_precset(prec,mld_sub_restr_,prec_choice%restr,info) + call mld_precset(prec,mld_sub_prol_,prec_choice%prol,info) + call mld_precset(prec,mld_sub_solve_,prec_choice%solve,info) + call mld_precset(prec,mld_sub_fill_in_,prec_choice%fill1,info) + call mld_precset(prec,mld_fact_thrs_,prec_choice%thr1,info) + if (psb_toupper(prec_choice%prec) =='ML') then + call mld_precset(prec,mld_aggr_kind_,prec_choice%aggrkind,info) + call mld_precset(prec,mld_aggr_alg_,prec_choice%aggr_alg,info) + call mld_precset(prec,mld_ml_type_,prec_choice%mltype,info) + call mld_precset(prec,mld_ml_type_,prec_choice%mltype,info) + call mld_precset(prec,mld_smooth_pos_,prec_choice%smthpos,info) + call mld_precset(prec,mld_coarse_mat_,prec_choice%cmat,info) + call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info) + call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv) + call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv) + call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) + call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) + if (prec_choice%omega>=0.0) then + call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv) + end if + end if + + ! building the preconditioner + t1 = psb_wtime() + call mld_precbld(a,desc_a,prec,info) + tprec = psb_wtime()-t1 + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_precbld') + goto 9999 + end if + + + call psb_amx(ictxt, tprec) + + if(iam==psb_root_) then + write(*,'("Preconditioner time: ",es10.4)')tprec + write(*,'(" ")') + end if + + iparm = 0 + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + + call psb_amx(ictxt,t2) + call psb_geaxpby(sone,b_col,szero,r_col,desc_a,info) + call psb_spmm(-sone,a,x_col,sone,r_col,desc_a,info) + call psb_genrm2s(resmx,r_col,desc_a,info) + call psb_geamaxs(resmxp,r_col,desc_a,info) + + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + precsize = mld_sizeof(prec) + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam==psb_root_) then + call mld_prec_descr(6,prec) + write(*,'("Matrix: ",a)')mtrx_file + write(*,'("Computed solution on ",i8," processors")')np + write(*,'("Iterations to convergence : ",i6)')iter + write(*,'("Error estimate on exit : ",es10.4)')err + write(*,'("Time to buil prec. : ",es10.4)')tprec + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/(iter) + write(*,'("Total time : ",es10.4)')t2+tprec + write(*,'("Residual norm 2 : ",es10.4)')resmx + write(*,'("Residual norm inf : ",es10.4)')resmxp + write(*,'("Total memory occupation for A : ",i10)')amatsize + write(*,'("Total memory occupation for DESC_A : ",i10)')descsize + write(*,'("Total memory occupation for PREC : ",i10)')precsize + end if + + allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr) + if (ierr /= 0) then + write(0,*) 'allocation error: no data collection' + else + call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) + call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) + if (iam==psb_root_) then + write(0,'(" ")') + write(0,'("Saving x on file")') + write(20,*) 'matrix: ',mtrx_file + write(20,*) 'computed solution on ',np,' processors.' + write(20,*) 'iterations to convergence: ',iter + write(20,*) 'error estimate (infinity norm) on exit:', & + & ' ||r||/(||a||||x||+||b||) = ',err + write(20,*) 'max residual = ',resmx, resmxp + write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)' + do i=1,m_problem + write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i) + enddo + end if + end if +998 format(i8,4(2x,g20.14)) +993 format(i6,4(1x,e12.6)) + + + call psb_gefree(b_col, desc_a,info) + call psb_gefree(x_col, desc_a,info) + call psb_spfree(a, desc_a,info) + call mld_precfree(prec,info) + call psb_cdfree(desc_a,info) + +9999 continue + if(info /= 0) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(icontxt,mtrx,rhs,kmethd,& + & prec, ipart,afmt,istopc,itmax,itrace,irst,eps) + + use psb_base_mod + implicit none + + integer :: icontxt + character(len=*) :: kmethd, mtrx, rhs, afmt + type(precdata) :: prec + integer :: iret, istopc,itmax,itrace, ipart, irst + real(psb_spk_) :: eps, omega,thr1,thr2 + integer :: iam, nm, np, i + + call psb_info(icontxt,iam,np) + + if (iam==psb_root_) then + ! read input parameters + call read_data(mtrx,5) + call read_data(rhs,5) + call read_data(kmethd,5) + call read_data(afmt,5) + call read_data(ipart,5) + call read_data(istopc,5) + call read_data(itmax,5) + call read_data(itrace,5) + call read_data(irst,5) + call read_data(eps,5) + call read_data(prec%descr,5) ! verbose description of the prec + call read_data(prec%prec,5) ! overall prectype + call read_data(prec%novr,5) ! number of overlap layers + call read_data(prec%restr,5) ! restriction over application of as + call read_data(prec%prol,5) ! prolongation over application of as + call read_data(prec%solve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%fill1,5) ! Fill-in for factorization 1 + call read_data(prec%thr1,5) ! Threshold for fact. 1 ILU(T) + if (psb_toupper(prec%prec) == 'ML') then + call read_data(prec%nlev,5) ! Number of levels in multilevel prec. + call read_data(prec%aggrkind,5) ! smoothed/raw aggregatin + call read_data(prec%aggr_alg,5) ! local or global aggregation + call read_data(prec%mltype,5) ! additive or multiplicative 2nd level prec + call read_data(prec%smthpos,5) ! side: pre, post, both smoothing + call read_data(prec%cmat,5) ! coarse mat + call read_data(prec%csolve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%cfill,5) ! Fill-in for factorization 1 + call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T) + call read_data(prec%cjswp,5) ! Jacobi sweeps + call read_data(prec%omega,5) ! smoother omega + end if + end if + + call psb_bcast(icontxt,mtrx) + call psb_bcast(icontxt,rhs) + call psb_bcast(icontxt,kmethd) + call psb_bcast(icontxt,afmt) + call psb_bcast(icontxt,ipart) + call psb_bcast(icontxt,istopc) + call psb_bcast(icontxt,itmax) + call psb_bcast(icontxt,itrace) + call psb_bcast(icontxt,irst) + call psb_bcast(icontxt,eps) + + call psb_bcast(icontxt,prec%descr) ! verbose description of the prec + call psb_bcast(icontxt,prec%prec) ! overall prectype + call psb_bcast(icontxt,prec%novr) ! number of overlap layers + call psb_bcast(icontxt,prec%restr) ! restriction over application of as + call psb_bcast(icontxt,prec%prol) ! prolongation over application of as + call psb_bcast(icontxt,prec%solve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(icontxt,prec%fill1) ! Fill-in for factorization 1 + call psb_bcast(icontxt,prec%thr1) ! Threshold for fact. 1 ILU(T) + if (psb_toupper(prec%prec) == 'ML') then + call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. + call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin + call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec + call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing + call psb_bcast(icontxt,prec%cmat) ! coarse mat + call psb_bcast(icontxt,prec%csolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(icontxt,prec%cfill) ! Fill-in for factorization 1 + call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T) + call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps + call psb_bcast(icontxt,prec%omega) ! smoother omega + end if + + end subroutine get_parms + subroutine pr_usage(iout) + integer iout + write(iout, *) ' number of parameters is incorrect!' + write(iout, *) ' use: hb_sample mtrx_file methd prec [ptype & + &itmax istopc itrace]' + write(iout, *) ' where:' + write(iout, *) ' mtrx_file is stored in hb format' + write(iout, *) ' methd may be: cgstab ' + write(iout, *) ' itmax max iterations [500] ' + write(iout, *) ' istopc stopping criterion [1] ' + write(iout, *) ' itrace 0 (no tracing, default) or ' + write(iout, *) ' >= 0 do tracing every itrace' + write(iout, *) ' iterations ' + write(iout, *) ' prec may be: ilu diagsc none' + write(iout, *) ' ptype partition strategy default 0' + write(iout, *) ' 0: block partition ' + end subroutine pr_usage +end program sf_sample + + + + + diff --git a/test/fileread/zf_sample.f90 b/test/fileread/zf_sample.f90 new file mode 100644 index 00000000..7e12667d --- /dev/null +++ b/test/fileread/zf_sample.f90 @@ -0,0 +1,454 @@ +!!$ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 MLD2P4 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 MLD2P4 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. +!!$ +!!$ +program zf_sample + use psb_base_mod + use mld_prec_mod + use psb_krylov_mod + use psb_util_mod + use data_input + implicit none + + + ! input parameters + character(len=40) :: kmethd, mtrx_file, rhs_file + type precdata + character(len=20) :: descr ! verbose description of the prec + character(len=10) :: prec ! overall prectype + integer :: novr ! number of overlap layers + character(len=16) :: restr ! restriction over application of as + character(len=16) :: prol ! prolongation over application of as + character(len=16) :: solve ! Factorization type: ILU, SuperLU, UMFPACK. + integer :: fill1 ! Fill-in for factorization 1 + real(psb_dpk_) :: thr1 ! Threshold for fact. 1 ILU(T) + integer :: nlev ! Number of levels in multilevel prec. + character(len=16) :: aggrkind ! smoothed/raw aggregatin + character(len=16) :: aggr_alg ! local or global aggregation + character(len=16) :: mltype ! additive or multiplicative 2nd level prec + character(len=16) :: smthpos ! side: pre, post, both smoothing + character(len=16) :: cmat ! coarse mat + character(len=16) :: csolve ! Factorization type: ILU, SuperLU, UMFPACK. + integer :: cfill ! Fill-in for factorization 1 + real(psb_dpk_) :: cthres ! Threshold for fact. 1 ILU(T) + integer :: cjswp ! Jacobi sweeps + real(psb_dpk_) :: omega ! smoother omega + end type precdata + type(precdata) :: prec_choice + + ! sparse matrices + type(psb_zspmat_type) :: a, aux_a + + ! preconditioner data + type(mld_zprec_type) :: prec + + ! dense matrices + complex(kind(1.d0)), allocatable, target :: aux_b(:,:), d(:) + complex(kind(1.d0)), allocatable , save :: b_col(:), x_col(:), r_col(:), & + & x_col_glob(:), r_col_glob(:) + complex(kind(1.d0)), pointer :: b_col_glob(:) + + ! communications data structure + type(psb_desc_type):: desc_a + + integer :: ictxt, iam, np + + ! solver paramters + integer :: iter, itmax, ierr, itrace, ircode, ipart,& + & methd, istopc, irst,amatsize,precsize,descsize, nlv + real(kind(1.d0)) :: err, eps + + character(len=5) :: afmt + character(len=20) :: name + integer :: iparm(20) + + ! other variables + integer :: i,info,j,m_problem + integer :: internal, m,ii,nnzero + real(kind(1.d0)) :: t1, t2, tprec, r_amax, b_amax,& + &scale,resmx,resmxp + integer :: nrhs, nrow, n_row, dim, nv, ne + integer, allocatable :: ivg(:), ipv(:) + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + + + name='df_sample' + if(psb_get_errstatus() /= 0) goto 9999 + info=0 + call psb_set_errverbosity(2) + ! + ! get parameters + ! + call get_parms(ictxt,mtrx_file,rhs_file,kmethd,& + & prec_choice,ipart,afmt,istopc,itmax,itrace,irst,eps) + + call psb_barrier(ictxt) + t1 = psb_wtime() + ! read the input matrix to be processed and (possibly) the rhs + nrhs = 1 + + if (iam==psb_root_) then + call read_mat(mtrx_file, aux_a, ictxt) + + m_problem = aux_a%m + call psb_bcast(ictxt,m_problem) + + if(rhs_file /= 'NONE') then + ! reading an rhs + call read_rhs(rhs_file,aux_b,ictxt) + end if + + if (psb_size(aux_b,dim=1)==m_problem) then + ! if any rhs were present, broadcast the first one + write(0,'("Ok, got an rhs ")') + b_col_glob =>aux_b(:,1) + else + write(*,'("Generating an rhs...")') + write(*,'(" ")') + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + + b_col_glob => aux_b(:,1) + do i=1, m_problem + b_col_glob(i) = 1.d0 + enddo + endif + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + else + call psb_bcast(ictxt,m_problem) + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + b_col_glob =>aux_b(:,1) + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + end if + + ! switch over different partition types + if (ipart == 0) then + call psb_barrier(ictxt) + if (iam==psb_root_) write(*,'("Partition type: block")') + allocate(ivg(m_problem),ipv(np)) + do i=1,m_problem + call part_block(i,m_problem,np,ipv,nv) + ivg(i) = ipv(1) + enddo + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else if (ipart == 2) then + if (iam==psb_root_) then + write(*,'("Partition type: graph")') + write(*,'(" ")') + ! write(0,'("Build type: graph")') + call build_mtpart(aux_a%m,aux_a%fida,aux_a%ia1,aux_a%ia2,np) + endif + call psb_barrier(ictxt) + call distr_mtpart(psb_root_,ictxt) + call getv_mtpart(ivg) + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else + if (iam==psb_root_) write(*,'("Partition type: block")') + call psb_matdist(aux_a, a, part_block, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + end if + + call psb_geall(x_col,desc_a,info) + x_col(:) =0.0 + call psb_geasb(x_col,desc_a,info) + call psb_geall(r_col,desc_a,info) + r_col(:) =0.0 + call psb_geasb(r_col,desc_a,info) + t2 = psb_wtime() - t1 + + + call psb_amx(ictxt, t2) + + if (iam==psb_root_) then + write(*,'(" ")') + write(*,'("Time to read and partition matrix : ",es10.4)')t2 + write(*,'(" ")') + write(*,*) 'Preconditioner: ',prec_choice%descr + end if + + ! + + if (psb_toupper(prec_choice%prec) =='ML') then + nlv = prec_choice%nlev + else + nlv = 1 + end if + call mld_precinit(prec,prec_choice%prec,info,nlev=nlv) + call mld_precset(prec,mld_n_ovr_,prec_choice%novr,info) + call mld_precset(prec,mld_sub_restr_,prec_choice%restr,info) + call mld_precset(prec,mld_sub_prol_,prec_choice%prol,info) + call mld_precset(prec,mld_sub_solve_,prec_choice%solve,info) + call mld_precset(prec,mld_sub_fill_in_,prec_choice%fill1,info) + call mld_precset(prec,mld_fact_thrs_,prec_choice%thr1,info) + if (psb_toupper(prec_choice%prec) =='ML') then + call mld_precset(prec,mld_aggr_kind_,prec_choice%aggrkind,info) + call mld_precset(prec,mld_aggr_alg_,prec_choice%aggr_alg,info) + call mld_precset(prec,mld_ml_type_,prec_choice%mltype,info) + call mld_precset(prec,mld_ml_type_,prec_choice%mltype,info) + call mld_precset(prec,mld_smooth_pos_,prec_choice%smthpos,info) + call mld_precset(prec,mld_coarse_mat_,prec_choice%cmat,info) + call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info) + call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv) + call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv) + call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) + call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) + if (prec_choice%omega>=0.0) then + call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv) + end if + end if + + ! building the preconditioner + t1 = psb_wtime() + call mld_precbld(a,desc_a,prec,info) + tprec = psb_wtime()-t1 + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_precbld') + goto 9999 + end if + + + call psb_amx(ictxt, tprec) + + if(iam==psb_root_) then + write(*,'("Preconditioner time: ",es10.4)')tprec + write(*,'(" ")') + end if + + iparm = 0 + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + + call psb_amx(ictxt,t2) + call psb_geaxpby(zone,b_col,zzero,r_col,desc_a,info) + call psb_spmm(-zone,a,x_col,zone,r_col,desc_a,info) + call psb_genrm2s(resmx,r_col,desc_a,info) + call psb_geamaxs(resmxp,r_col,desc_a,info) + + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + precsize = mld_sizeof(prec) + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam==psb_root_) then + call mld_prec_descr(6,prec) + write(*,'("Matrix: ",a)')mtrx_file + write(*,'("Computed solution on ",i8," processors")')np + write(*,'("Iterations to convergence : ",i6)')iter + write(*,'("Error estimate on exit : ",es10.4)')err + write(*,'("Time to buil prec. : ",es10.4)')tprec + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/(iter) + write(*,'("Total time : ",es10.4)')t2+tprec + write(*,'("Residual norm 2 : ",es10.4)')resmx + write(*,'("Residual norm inf : ",es10.4)')resmxp + write(*,'("Total memory occupation for A : ",i10)')amatsize + write(*,'("Total memory occupation for DESC_A : ",i10)')descsize + write(*,'("Total memory occupation for PREC : ",i10)')precsize + end if + + allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr) + if (ierr /= 0) then + write(0,*) 'allocation error: no data collection' + else + call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) + call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) + if (iam==psb_root_) then + write(0,'(" ")') + write(0,'("Saving x on file")') + write(20,*) 'matrix: ',mtrx_file + write(20,*) 'computed solution on ',np,' processors.' + write(20,*) 'iterations to convergence: ',iter + write(20,*) 'error estimate (infinity norm) on exit:', & + & ' ||r||/(||a||||x||+||b||) = ',err + write(20,*) 'max residual = ',resmx, resmxp + write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)' + do i=1,m_problem + write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i) + enddo + end if + end if +998 format(i8,4(2x,g20.14)) +993 format(i6,4(1x,e12.6)) + + + call psb_gefree(b_col, desc_a,info) + call psb_gefree(x_col, desc_a,info) + call psb_spfree(a, desc_a,info) + call mld_precfree(prec,info) + call psb_cdfree(desc_a,info) + +9999 continue + if(info /= 0) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(icontxt,mtrx,rhs,kmethd,& + & prec, ipart,afmt,istopc,itmax,itrace,irst,eps) + + use psb_base_mod + implicit none + + integer :: icontxt + character(len=*) :: kmethd, mtrx, rhs, afmt + type(precdata) :: prec + integer :: iret, istopc,itmax,itrace, ipart, irst + real(psb_dpk_) :: eps, omega,thr1,thr2 + integer :: iam, nm, np, i + + call psb_info(icontxt,iam,np) + + if (iam==psb_root_) then + ! read input parameters + call read_data(mtrx,5) + call read_data(rhs,5) + call read_data(kmethd,5) + call read_data(afmt,5) + call read_data(ipart,5) + call read_data(istopc,5) + call read_data(itmax,5) + call read_data(itrace,5) + call read_data(irst,5) + call read_data(eps,5) + call read_data(prec%descr,5) ! verbose description of the prec + call read_data(prec%prec,5) ! overall prectype + call read_data(prec%novr,5) ! number of overlap layers + call read_data(prec%restr,5) ! restriction over application of as + call read_data(prec%prol,5) ! prolongation over application of as + call read_data(prec%solve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%fill1,5) ! Fill-in for factorization 1 + call read_data(prec%thr1,5) ! Threshold for fact. 1 ILU(T) + if (psb_toupper(prec%prec) == 'ML') then + call read_data(prec%nlev,5) ! Number of levels in multilevel prec. + call read_data(prec%aggrkind,5) ! smoothed/raw aggregatin + call read_data(prec%aggr_alg,5) ! local or global aggregation + call read_data(prec%mltype,5) ! additive or multiplicative 2nd level prec + call read_data(prec%smthpos,5) ! side: pre, post, both smoothing + call read_data(prec%cmat,5) ! coarse mat + call read_data(prec%csolve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%cfill,5) ! Fill-in for factorization 1 + call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T) + call read_data(prec%cjswp,5) ! Jacobi sweeps + call read_data(prec%omega,5) ! smoother omega + end if + end if + + call psb_bcast(icontxt,mtrx) + call psb_bcast(icontxt,rhs) + call psb_bcast(icontxt,kmethd) + call psb_bcast(icontxt,afmt) + call psb_bcast(icontxt,ipart) + call psb_bcast(icontxt,istopc) + call psb_bcast(icontxt,itmax) + call psb_bcast(icontxt,itrace) + call psb_bcast(icontxt,irst) + call psb_bcast(icontxt,eps) + + call psb_bcast(icontxt,prec%descr) ! verbose description of the prec + call psb_bcast(icontxt,prec%prec) ! overall prectype + call psb_bcast(icontxt,prec%novr) ! number of overlap layers + call psb_bcast(icontxt,prec%restr) ! restriction over application of as + call psb_bcast(icontxt,prec%prol) ! prolongation over application of as + call psb_bcast(icontxt,prec%solve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(icontxt,prec%fill1) ! Fill-in for factorization 1 + call psb_bcast(icontxt,prec%thr1) ! Threshold for fact. 1 ILU(T) + if (psb_toupper(prec%prec) == 'ML') then + call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. + call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin + call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec + call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing + call psb_bcast(icontxt,prec%cmat) ! coarse mat + call psb_bcast(icontxt,prec%csolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(icontxt,prec%cfill) ! Fill-in for factorization 1 + call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T) + call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps + call psb_bcast(icontxt,prec%omega) ! smoother omega + end if + + end subroutine get_parms + subroutine pr_usage(iout) + integer iout + write(iout, *) ' number of parameters is incorrect!' + write(iout, *) ' use: hb_sample mtrx_file methd prec [ptype & + &itmax istopc itrace]' + write(iout, *) ' where:' + write(iout, *) ' mtrx_file is stored in hb format' + write(iout, *) ' methd may be: cgstab ' + write(iout, *) ' itmax max iterations [500] ' + write(iout, *) ' istopc stopping criterion [1] ' + write(iout, *) ' itrace 0 (no tracing, default) or ' + write(iout, *) ' >= 0 do tracing every itrace' + write(iout, *) ' iterations ' + write(iout, *) ' prec may be: ilu diagsc none' + write(iout, *) ' ptype partition strategy default 0' + write(iout, *) ' 0: block partition ' + end subroutine pr_usage +end program zf_sample + + + + + diff --git a/test/pargen/Makefile b/test/pargen/Makefile index b617d414..bacabfd2 100644 --- a/test/pargen/Makefile +++ b/test/pargen/Makefile @@ -14,13 +14,16 @@ ppde: ppde.o $(F90LINK) ppde.o -o ppde $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv ppde $(EXEDIR) +spde: spde.o + $(F90LINK) spde.o -o spde $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) + /bin/mv spde $(EXEDIR) .f90.o: $(MPF90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $< - clean: - /bin/rm -f ppde.o $(EXEDIR)/ppde + /bin/rm -f ppde.o $(EXEDIR)/ppde spde.o $(EXEDIR)/spde + verycleanlib: (cd ../..; make veryclean) lib: diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index 4716e938..c9784b19 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -1,12 +1,12 @@ BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD -80 ! IDIM; domain size is idim**3 +30 ! IDIM; domain size is idim**3 2 ! ISTOPC -01000 ! ITMAX --1 ! ITRACE +00800 ! ITMAX +01 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS -3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) +2L-M-RAS-S-D4 ! Longer descriptive name for preconditioner (up to 20 chars) ML ! Preconditioner NONE DIAG BJAC AS ML 0 ! Number of overlap layers for AS preconditioner at finest level HALO ! Restriction operator NONE HALO @@ -20,9 +20,8 @@ DEC ! Type of aggregation DEC SYMDEC GLB MULT ! Type of multilevel correction: ADD MULT POST ! Side of multiplicative correction PRE POST BOTH (ignored for ADD) DIST ! Coarse level: matrix distribution DIST REPL -UMF ! Coarse level: solver ILU ILUT UMF SLU SLUDIST +SLU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST 0 ! Coarse level: Level-set N for ILU(N) 1.d-4 ! Coarse level: Threshold T for ILU(T,P) 4 ! Coarse level: Number of Jacobi sweeps -1.0d0 ! Smoother Omega: if < 0 means library choice. - diff --git a/test/pargen/spde.f90 b/test/pargen/spde.f90 new file mode 100644 index 00000000..3ae92b0b --- /dev/null +++ b/test/pargen/spde.f90 @@ -0,0 +1,795 @@ +!!$ +!!$ MLD2P4 version 1.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 2.2) +!!$ +!!$ (C) Copyright 2008 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ 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 PSBLAS 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 PSBLAS 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: ppde.f90 +! +! Program: ppde +! This sample program shows how to build and solve a sparse linear +! +! The program solves a linear system based on the partial differential +! equation +! +! +! +! The equation generated is +! +! b1 d d (u) b2 d d (u) a1 d (u)) a2 d (u))) +! - ------ - ------ + ----- + ------ + a3 u = 0 +! dx dx dy dy dx dy +! +! +! with Dirichlet boundary conditions on the unit cube +! +! 0<=x,y,z<=1 +! +! The equation is discretized with finite differences and uniform stepsize; +! the resulting discrete equation is +! +! ( u(x,y,z)(2b1+2b2+a1+a2)+u(x-1,y)(-b1-a1)+u(x,y-1)(-b2-a2)+ +! -u(x+1,y)b1-u(x,y+1)b2)*(1/h**2) +! +! Example taken from: C.T.Kelley +! Iterative Methods for Linear and Nonlinear Equations +! SIAM 1995 +! +! +! In this sample program the index space of the discretized +! computational domain is first numbered sequentially in a standard way, +! then the corresponding vector is distributed according to a BLOCK +! data distribution. +! +! Boundary conditions are set in a very simple way, by adding +! equations of the form +! +! u(x,y) = rhs(x,y) +! + +module data_input + + interface read_data + module procedure read_char, read_int,& + & read_double, read_single + end interface read_data + +contains + + subroutine read_char(val,file) + character(len=*), intent(out) :: val + integer, intent(in) :: file + character(len=1024) :: charbuf + integer :: idx + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,"!") + read(charbuf(1:idx-1),'(a)') val +!!$ write(0,*) 'read_char got value: "',val,'"' + end subroutine read_char + subroutine read_int(val,file) + integer, intent(out) :: val + integer, intent(in) :: file + character(len=1024) :: charbuf + integer :: idx + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,"!") + read(charbuf(1:idx-1),*) val +!!$ write(0,*) 'read_int got value: ',val + end subroutine read_int + subroutine read_single(val,file) + use psb_base_mod + real(psb_spk_), intent(out) :: val + integer, intent(in) :: file + character(len=1024) :: charbuf + integer :: idx + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,"!") + read(charbuf(1:idx-1),*) val +!!$ write(0,*) 'read_double got value: ',val + end subroutine read_single + subroutine read_double(val,file) + use psb_base_mod + real(psb_dpk_), intent(out) :: val + integer, intent(in) :: file + character(len=1024) :: charbuf + integer :: idx + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,"!") + read(charbuf(1:idx-1),*) val +!!$ write(0,*) 'read_double got value: ',val + end subroutine read_double +end module data_input + +program spde + use psb_base_mod + use mld_prec_mod + use psb_krylov_mod + use psb_util_mod + use data_input + implicit none + + ! input parameters + character(len=20) :: kmethd, ptype + character(len=5) :: afmt + integer :: idim + + ! miscellaneous + real(psb_spk_), parameter :: one = 1.0 + real(psb_dpk_) :: t1, t2, tprec + + ! sparse matrix and preconditioner + type(psb_sspmat_type) :: a + type(mld_sprec_type) :: prec + ! descriptor + type(psb_desc_type) :: desc_a + ! dense matrices + real(psb_spk_), allocatable :: b(:), x(:) + ! blacs parameters + integer :: ictxt, iam, np + + ! solver parameters + integer :: iter, itmax,itrace, istopc, irst, nlv + real(psb_spk_) :: err, eps + + type precdata + character(len=20) :: descr ! verbose description of the prec + character(len=10) :: prec ! overall prectype + integer :: novr ! number of overlap layers + character(len=16) :: restr ! restriction over application of as + character(len=16) :: prol ! prolongation over application of as + character(len=16) :: solve ! Factorization type: ILU, SuperLU, UMFPACK. + integer :: fill1 ! Fill-in for factorization 1 + real(psb_spk_) :: thr1 ! Threshold for fact. 1 ILU(T) + integer :: nlev ! Number of levels in multilevel prec. + character(len=16) :: aggrkind ! smoothed/raw aggregatin + character(len=16) :: aggr_alg ! local or global aggregation + character(len=16) :: mltype ! additive or multiplicative 2nd level prec + character(len=16) :: smthpos ! side: pre, post, both smoothing + character(len=16) :: cmat ! coarse mat + character(len=16) :: csolve ! Factorization type: ILU, SuperLU, UMFPACK. + integer :: cfill ! Fill-in for factorization 1 + real(psb_spk_) :: cthres ! Threshold for fact. 1 ILU(T) + integer :: cjswp ! Jacobi sweeps + real(psb_spk_) :: omega ! smoother omega + end type precdata + type(precdata) :: prectype + ! other variables + integer :: info + character(len=20) :: name,ch_err + + info=0 + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='pde90' + call psb_set_errverbosity(2) + + ! + ! get parameters + ! + call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst) + + ! + ! allocate and fill in the coefficient matrix, rhs and initial guess + ! + + call psb_barrier(ictxt) + t1 = psb_wtime() + call create_matrix(idim,a,b,x,desc_a,part_block,ictxt,afmt,info) + t2 = psb_wtime() - t1 + if(info /= 0) then + info=4010 + ch_err='create_matrix' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_amx(ictxt,t2) + if (iam == psb_root_) write(*,'("Overall matrix creation time : ",es10.4)')t2 + if (iam == psb_root_) write(*,'(" ")') + ! + ! prepare the preconditioner. + ! + + if (psb_toupper(prectype%prec) =='ML') then + nlv = prectype%nlev + else + nlv = 1 + end if + call mld_precinit(prec,prectype%prec,info,nlev=nlv) + call mld_precset(prec,mld_n_ovr_,prectype%novr,info) + call mld_precset(prec,mld_sub_restr_,prectype%restr,info) + call mld_precset(prec,mld_sub_prol_,prectype%prol,info) + call mld_precset(prec,mld_sub_solve_,prectype%solve,info) + call mld_precset(prec,mld_sub_fill_in_,prectype%fill1,info) + call mld_precset(prec,mld_fact_thrs_,prectype%thr1,info) + if (psb_toupper(prectype%prec) =='ML') then + call mld_precset(prec,mld_aggr_kind_,prectype%aggrkind,info) + call mld_precset(prec,mld_aggr_alg_,prectype%aggr_alg,info) + call mld_precset(prec,mld_ml_type_,prectype%mltype,info) + call mld_precset(prec,mld_ml_type_,prectype%mltype,info) + call mld_precset(prec,mld_smooth_pos_,prectype%smthpos,info) + call mld_precset(prec,mld_coarse_mat_,prectype%cmat,info) + call mld_precset(prec,mld_coarse_solve_,prectype%csolve,info) + call mld_precset(prec,mld_sub_fill_in_,prectype%cfill,info,ilev=nlv) + call mld_precset(prec,mld_fact_thrs_,prectype%cthres,info,ilev=nlv) + call mld_precset(prec,mld_smooth_sweeps_,prectype%cjswp,info,ilev=nlv) + call mld_precset(prec,mld_smooth_sweeps_,prectype%cjswp,info,ilev=nlv) + if (prectype%omega>=0.0) then + call mld_precset(prec,mld_aggr_damp_,prectype%omega,info,ilev=nlv) + end if + end if + + + call psb_barrier(ictxt) + t1 = psb_wtime() + call mld_precbld(a,desc_a,prec,info) + if(info /= 0) then + info=4010 + ch_err='psb_precbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + tprec = psb_wtime()-t1 + + call psb_amx(ictxt,tprec) + + if (iam == psb_root_) write(*,'("Preconditioner time : ",es10.4)')tprec + if (iam == psb_root_) call mld_prec_descr(6,prec) + if (iam == psb_root_) write(*,'(" ")') + + ! + ! iterative method parameters + ! + if(iam == psb_root_) write(*,'("Calling iterative method ",a)')kmethd + call psb_barrier(ictxt) + t1 = psb_wtime() + eps = 1.d-9 + call psb_krylov(kmethd,a,prec,b,x,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + + if(info /= 0) then + info=4010 + ch_err='solver routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + call psb_amx(ictxt,t2) + + if (iam == psb_root_) then + write(*,'(" ")') + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/iter + write(*,'("Number of iterations : ",i0)')iter + write(*,'("Convergence indicator on exit : ",es10.4)')err + write(*,'("Info on exit : ",i0)')info + end if + + ! + ! cleanup storage and exit + ! + call psb_gefree(b,desc_a,info) + call psb_gefree(x,desc_a,info) + call psb_spfree(a,desc_a,info) + call mld_precfree(prec,info) + call psb_cdfree(desc_a,info) + if(info /= 0) then + info=4010 + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + +9999 continue + if(info /= 0) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +contains + ! + ! get iteration parameters from the command line + ! + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst) + integer :: ictxt + type(precdata) :: prectype + character(len=*) :: kmethd, afmt + integer :: idim, istopc,itmax,itrace,irst + integer :: np, iam, info + character(len=20) :: buffer + + call psb_info(ictxt, iam, np) + + if (iam==psb_root_) then + call read_data(kmethd,5) + call read_data(afmt,5) + call read_data(idim,5) + call read_data(istopc,5) + call read_data(itmax,5) + call read_data(itrace,5) + call read_data(irst,5) + call read_data(eps,5) + call read_data(prectype%descr,5) ! verbose description of the prec + call read_data(prectype%prec,5) ! overall prectype + call read_data(prectype%novr,5) ! number of overlap layers + call read_data(prectype%restr,5) ! restriction over application of as + call read_data(prectype%prol,5) ! prolongation over application of as + call read_data(prectype%solve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%fill1,5) ! Fill-in for factorization 1 + call read_data(prectype%thr1,5) ! Threshold for fact. 1 ILU(T) + if (psb_toupper(prectype%prec) == 'ML') then + call read_data(prectype%nlev,5) ! Number of levels in multilevel prec. + call read_data(prectype%aggrkind,5) ! smoothed/raw aggregatin + call read_data(prectype%aggr_alg,5) ! local or global aggregation + call read_data(prectype%mltype,5) ! additive or multiplicative 2nd level prec + call read_data(prectype%smthpos,5) ! side: pre, post, both smoothing + call read_data(prectype%cmat,5) ! coarse mat + call read_data(prectype%csolve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%cfill,5) ! Fill-in for factorization 1 + call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%cjswp,5) ! Jacobi sweeps + call read_data(prectype%omega,5) ! smoother omega + end if + end if + + ! broadcast parameters to all processors + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,afmt) + call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,istopc) + call psb_bcast(ictxt,itmax) + call psb_bcast(ictxt,itrace) + call psb_bcast(ictxt,irst) + + + call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec + call psb_bcast(ictxt,prectype%prec) ! overall prectype + call psb_bcast(ictxt,prectype%novr) ! number of overlap layers + call psb_bcast(ictxt,prectype%restr) ! restriction over application of as + call psb_bcast(ictxt,prectype%prol) ! prolongation over application of as + call psb_bcast(ictxt,prectype%solve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%fill1) ! Fill-in for factorization 1 + call psb_bcast(ictxt,prectype%thr1) ! Threshold for fact. 1 ILU(T) + if (psb_toupper(prectype%prec) == 'ML') then + call psb_bcast(ictxt,prectype%nlev) ! Number of levels in multilevel prec. + call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/raw aggregatin + call psb_bcast(ictxt,prectype%aggr_alg) ! local or global aggregation + call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec + call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing + call psb_bcast(ictxt,prectype%cmat) ! coarse mat + call psb_bcast(ictxt,prectype%csolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%cfill) ! Fill-in for factorization 1 + call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) + call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps + call psb_bcast(ictxt,prectype%omega) ! smoother omega + end if + + if (iam==psb_root_) then + write(*,'("Solving matrix : ell1")') + write(*,'("Grid dimensions : ",i4,"x",i4,"x",i4)')idim,idim,idim + write(*,'("Number of processors : ",i0)') np + write(*,'("Data distribution : BLOCK")') + write(*,'("Preconditioner : ",a)') prectype%descr + write(*,'("Iterative method : ",a)') kmethd + write(*,'(" ")') + endif + + return + + end subroutine get_parms + + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer :: iout + write(iout,*)'incorrect parameter(s) found' + write(iout,*)' usage: pde90 methd prec dim & + &[istop itmax itrace]' + write(iout,*)' where:' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' prec : bjac diag none' + write(iout,*)' dim number of points along each axis' + write(iout,*)' the size of the resulting linear ' + write(iout,*)' system is dim**3' + write(iout,*)' istop stopping criterion 1, 2 ' + write(iout,*)' itmax maximum number of iterations [500] ' + write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' >= 1 do tracing every itrace' + write(iout,*)' iterations ' + end subroutine pr_usage + + ! + ! subroutine to allocate and fill in the coefficient matrix and + ! the rhs. + ! + subroutine create_matrix(idim,a,b,xv,desc_a,parts,ictxt,afmt,info) + ! + ! discretize the partial diferential equation + ! + ! b1 dd(u) b2 dd(u) b3 dd(u) a1 d(u) a2 d(u) a3 d(u) + ! - ------ - ------ - ------ - ----- - ------ - ------ + a4 u + ! dxdx dydy dzdz dx dy dz + ! + ! = 0 + ! + ! boundary condition: dirichlet + ! 0< x,y,z<1 + ! + ! u(x,y,z)(2b1+2b2+2b3+a1+a2+a3)+u(x-1,y,z)(-b1-a1)+u(x,y-1,z)(-b2-a2)+ + ! + u(x,y,z-1)(-b3-a3)-u(x+1,y,z)b1-u(x,y+1,z)b2-u(x,y,z+1)b3 + + use psb_base_mod + implicit none + integer :: idim + integer, parameter :: nbmax=10 + real(psb_spk_), allocatable :: b(:),xv(:) + type(psb_desc_type) :: desc_a + integer :: ictxt, info + character :: afmt*5 + interface + ! .....user passed subroutine..... + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface ! local variables + type(psb_sspmat_type) :: a + real(psb_spk_) :: zt(nbmax),glob_x,glob_y,glob_z + integer :: m,n,nnz,glob_row + integer :: x,y,z,ia,indx_owner + integer :: np, iam + integer :: element + integer :: nv, inv + integer, allocatable :: irow(:),icol(:) + real(psb_spk_), allocatable :: val(:) + integer, allocatable :: prv(:) + ! deltah dimension of each grid cell + ! deltat discretization time + real(psb_spk_) :: deltah + real(psb_spk_),parameter :: rhs=0.0,one=1.0,zero=0.0 + real(psb_dpk_) :: t1, t2, t3, tins, tasb + real(psb_spk_) :: a1, a2, a3, a4, b1, b2, b3 + external :: a1, a2, a3, a4, b1, b2, b3 + integer :: err_act + ! common area + + character(len=20) :: name, ch_err + + info = 0 + name = 'create_matrix' + call psb_erractionsave(err_act) + + call psb_info(ictxt, iam, np) + + deltah = 1.0/(idim-1) + + ! initialize array descriptor and sparse matrix storage. provide an + ! estimate of the number of non zeroes + + m = idim*idim*idim + n = m + nnz = ((n*9)/(np)) + if(iam == psb_root_) write(0,'("Generating Matrix (size=",i0x,")...")')n + + call psb_cdall(ictxt,desc_a,info,mg=n,parts=parts) + call psb_spall(a,desc_a,info,nnz=nnz) + ! define rhs from boundary conditions; also build initial guess + call psb_geall(b,desc_a,info) + call psb_geall(xv,desc_a,info) + if(info /= 0) then + info=4010 + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! we build an auxiliary matrix consisting of one row at a + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! + allocate(val(20*nbmax),irow(20*nbmax),& + &icol(20*nbmax),prv(np),stat=info) + if (info /= 0 ) then + info=4000 + call psb_errpush(info,name) + goto 9999 + endif + + tins = 0.d0 + call psb_barrier(ictxt) + t1 = psb_wtime() + + ! loop over rows belonging to current process in a block + ! distribution. + + ! icol(1)=1 + do glob_row = 1, n + call parts(glob_row,n,np,prv,nv) + do inv = 1, nv + indx_owner = prv(inv) + if (indx_owner == iam) then + ! local matrix pointer + element=1 + ! compute gridpoint coordinates + if (mod(glob_row,(idim*idim)) == 0) then + x = glob_row/(idim*idim) + else + x = glob_row/(idim*idim)+1 + endif + if (mod((glob_row-(x-1)*idim*idim),idim) == 0) then + y = (glob_row-(x-1)*idim*idim)/idim + else + y = (glob_row-(x-1)*idim*idim)/idim+1 + endif + z = glob_row-(x-1)*idim*idim-(y-1)*idim + ! glob_x, glob_y, glob_x coordinates + glob_x=x*deltah + glob_y=y*deltah + glob_z=z*deltah + + ! check on boundary points + zt(1) = 0.d0 + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + if (x==1) then + val(element)=-b1(glob_x,glob_y,glob_z)& + & -a1(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*(-val(element)) + else + val(element)=-b1(glob_x,glob_y,glob_z)& + & -a1(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-2)*idim*idim+(y-1)*idim+(z) + element=element+1 + endif + ! term depending on (x,y-1,z) + if (y==1) then + val(element)=-b2(glob_x,glob_y,glob_z)& + & -a2(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element)) + else + val(element)=-b2(glob_x,glob_y,glob_z)& + & -a2(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y-2)*idim+(z) + element=element+1 + endif + ! term depending on (x,y,z-1) + if (z==1) then + val(element)=-b3(glob_x,glob_y,glob_z)& + & -a3(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element)) + else + val(element)=-b3(glob_x,glob_y,glob_z)& + & -a3(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y-1)*idim+(z-1) + element=element+1 + endif + ! term depending on (x,y,z) + val(element)=2*b1(glob_x,glob_y,glob_z)& + & +2*b2(glob_x,glob_y,glob_z)& + & +2*b3(glob_x,glob_y,glob_z)& + & +a1(glob_x,glob_y,glob_z)& + & +a2(glob_x,glob_y,glob_z)& + & +a3(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y-1)*idim+(z) + element=element+1 + ! term depending on (x,y,z+1) + if (z==idim) then + val(element)=-b1(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element)) + else + val(element)=-b1(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y-1)*idim+(z+1) + element=element+1 + endif + ! term depending on (x,y+1,z) + if (y==idim) then + val(element)=-b2(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element)) + else + val(element)=-b2(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y)*idim+(z) + element=element+1 + endif + ! term depending on (x+1,y,z) + if (x