fdurastante/amg4psblas
1
0
Fork 0
mirror of https://github.com/sfilippone/amg4psblas.git synced 2026-10-06 22:55:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

mld2p4:

Browse Source 
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.
This commit is contained in:
Salvatore Filippone
2008-05-27 09:09:26 +00:00
parent df016d8b60
commit 2535383aad
88 changed files with 27325 additions and 124 deletions
Download Patch File Download Diff File Expand all files Collapse all files
config/pac.m4
+1 -1
View File
@@ -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=""])
configure
Vendored
+2 -2
View File
@@ -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; }
krylov/Makefile
+5 -1
View File
@@ -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
krylov/psb_prec_mod.F90
+4
View File
@@ -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,&
mlprec/Makefile
+27 -5
View File
@@ -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)
mlprec/mld_basep_bld_mod.f90
+208
View File
@@ -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
mlprec/mld_caggrmap_bld.f90
+391
View File
@@ -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
mlprec/mld_caggrmat_asb.f90
+160
View File
@@ -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
mlprec/mld_caggrmat_raw_asb.F90
+284
View File
@@ -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
mlprec/mld_caggrmat_smth_asb.F90
+666
View File
@@ -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
mlprec/mld_cas_aply.f90
+407
View File
@@ -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
mlprec/mld_cas_bld.f90
+287
View File
@@ -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
mlprec/mld_cbaseprec_aply.f90
+193
View File
@@ -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
mlprec/mld_cbaseprec_bld.f90
+217
View File
@@ -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
mlprec/mld_cdiag_bld.f90
+159
View File
@@ -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
mlprec/mld_cfact_bld.f90
+485
View File
@@ -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
mlprec/mld_cilu0_fact.f90
+648
View File
@@ -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
mlprec/mld_cilu_bld.f90
+280
View File
@@ -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
mlprec/mld_ciluk_fact.f90
+971
View File
@@ -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.(k<i)) then
!
! Note: since U is scaled while copying it out (see iluk_copyout),
! we can use rwk in the update below
!
rwk = row(k)
row(k) = row(k) * d(k) ! d(k) == 1/a(k,k)
lrwk = rowlevs(k)
do jj=uia2(k),uia2(k+1)-1
j = uia1(jj)
if (j<=k) then
info = -i
return
endif
!
! Insert the index into the heap for further processing.
! The fill levels are initialized to a negative value. If we find
! one, it means that it is an as yet untouched index, so we need
! to insert it; otherwise it is already on the heap, there is no
! need to insert it more than once.
!
if (rowlevs(j)<0) then
call psb_insert_heap(j,heap,info)
if (info /= 0) return
rowlevs(j) = abs(rowlevs(j))
end if
!
! Update row(j) and the corresponding fill level
!
row(j) = row(j) - rwk * uaspk(jj)
rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1)
end do
end if
end do
end subroutine iluk_fact
!
! Subroutine: iluk_copyout
! Version: complex
! Note: internal subroutine of mld_ciluk_fact
!
! This routine copies a matrix row, computed by iluk_fact by applying an
! elimination step of the ILU(k) factorization, into the arrays laspk, uaspk,
! d, corresponding to the L factor, the U factor and the diagonal of U,
! respectively.
!
! Note that
! - the part of the row stored into uaspk is scaled by the corresponding diagonal
! entry, according to the LDU form of the incomplete factorization;
! - the inverse of the diagonal entries of U is actually stored into d; this is
! then managed in the solve stage associated to the ILU(k)/MILU(k) factorization;
! - if the MILU(k) factorization has been required (ialg == mld_milu_n_), the
! row entries discarded because their fill levels are too high are added to
! the diagonal entry of the row;
! - the row entries are stored in laspk and uaspk according to the CSR format;
! - the arrays row and rowlevs are re-initialized for future use in mld_iluk_fact
! (see also iluk_copyin and iluk_fact).
!
! This routine is used by mld_ciluk_factint in the computation of the
! ILU(k)/MILU(k) factorization of a local sparse matrix.
!
!
! Arguments:
! fill_in - integer, input.
! The fill-in level k in ILU(k)/MILU(k).
! ialg - integer, input.
! The type of incomplete factorization considered. The MILU(k)
! factorization is computed if ialg = 2 (= mld_milu_n_); the
! ILU(k) factorization otherwise.
! i - integer, input.
! The local index of the row to be copied.
! m - integer, input.
! The number of rows of the local matrix under factorization.
! row - complex(psb_spk_), dimension(:), input/output.
! It contains, input, the row to be copied, and, in output,
! the null vector (the latter is used in the next call to
! iluk_copyin in mld_iluk_fact).
! rowlevs - integer, dimension(:), input/output.
! In input rowlevs(k) contains the fill kevel of the k-th entry
! of the row to be copied. rowlevs(k) = -(m+1) indicates that
! this entry is zero; however, any rowlevs(k) = -(m+1) is not
! used by the routine. In output rowlevs(k) = -(m+1) for all k's
! (this is an inizialization for the next call to iluk_copyin
! in mld_iluk_factint).
! nidx - integer, input.
! The number of entries of the array row that have been examined
! during the elimination step carried out by the routine iluk_fact.
! idxs - integer, dimension(:), allocatable, input.
! The indices of the entries of the array row that have been
! examined during the elimination step carried out by the routine
! iluk_fact.
! l1 - integer, input/output.
! Pointer to the last occupied entry of laspk.
! l2 - integer, input/output.
! Pointer to the last occupied entry of uaspk.
! lia1 - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the L factor,
! copied in laspk row by row (see mld_ciluk_factint), 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, copied in laspk row by row (see
! mld_ciluk_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
! L factor are copied.
! d - complex(psb_spk_), dimension(:), input/output.
! The array where the inverse of the diagonal entry of the
! row is copied (only d(i) is used by the routine).
! uia1 - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the U factor
! copied in uaspk row by row (see mld_ciluk_factint), 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 copied in uaspk row by row (see
! mld_cilu_fctint), according to the CSR storage format.
! uaspk - complex(psb_spk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the
! U factor are copied.
! uplevs - integer, dimension(:), input.
! The fill levels of the nonzero entries in the part of the
! U factor above the current row.
!
subroutine iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,&
& l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,uplevs,info)
use psb_base_mod
implicit none
! Arguments
integer, intent(in) :: fill_in, ialg, i, m, nidx
integer, intent(inout) :: l1, l2, info
integer, intent(inout) :: rowlevs(:), idxs(:)
integer, allocatable, intent(inout) :: uia1(:), uia2(:), lia1(:), lia2(:),uplevs(:)
complex(psb_spk_), allocatable, intent(inout) :: uaspk(:), laspk(:)
complex(psb_spk_), intent(inout) :: row(:), d(:)
! Local variables
integer :: j,isz,err_act,int_err(5),idxp
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)
d(i) = dzero
do idxp=1,nidx
j = idxs(idxp)
if (j<i) then
!
! Copy the lower part of the row
!
if (rowlevs(j) <= fill_in) then
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) = j
laspk(l1) = row(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)
else if (j==i) then
!
! Copy the diagonal entry of the row and re-initialize
! row(j) and rowlevs(j)
!
d(i) = d(i) + row(i)
row(i) = czero
rowlevs(i) = -(m+1)
else if (j>i) 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
mlprec/mld_cilut_fact.f90
+1159
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_cmlprec_aply.f90
+1439
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_cmlprec_bld.f90
+180
View File
@@ -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
mlprec/mld_cprec_aply.f90
+261
View File
@@ -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
mlprec/mld_cprecbld.f90
+234
View File
@@ -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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
call init_baseprc_av(p%baseprecv(i),info)
if (debug_level >= 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
mlprec/mld_cprecfree.f90
+94
View File
@@ -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
mlprec/mld_cprecinit.f90
+252
View File
@@ -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
mlprec/mld_cprecset.f90
+637
View File
@@ -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
mlprec/mld_cslu_bld.f90
+129
View File
@@ -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
mlprec/mld_cslu_interface.c
+399
View File
@@ -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 <stdio.h>
#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
}
mlprec/mld_cslud_bld.f90
+149
View File
@@ -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
mlprec/mld_cslud_interface.c
+402
View File
@@ -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 <math.h>
#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 <stdio.h>
#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
}
mlprec/mld_csp_renum.f90
+368
View File
@@ -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
mlprec/mld_csub_aply.f90
+296
View File
@@ -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
mlprec/mld_csub_solve.f90
+325
View File
@@ -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
mlprec/mld_cumf_bld.f90
+138
View File
@@ -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
mlprec/mld_cumf_interface.c
+258
View File
@@ -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 <stdio.h>
/* 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
}
mlprec/mld_dmlprec_bld.f90
+1 -1
View File
@@ -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
mlprec/mld_dprecset.f90
+6 -6
View File
@@ -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
mlprec/mld_inner_mod.f90
+238
View File
@@ -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
mlprec/mld_prec_mod.f90
+146 -4
View File
@@ -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
mlprec/mld_prec_type.f90
+584 -10
View File
@@ -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
mlprec/mld_saggrmap_bld.f90
+390
View File
@@ -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
mlprec/mld_saggrmat_asb.f90
+160
View File
@@ -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
mlprec/mld_saggrmat_raw_asb.F90
+284
View File
@@ -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
mlprec/mld_saggrmat_smth_asb.F90
+666
View File
@@ -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
mlprec/mld_sas_aply.f90
+407
View File
@@ -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
mlprec/mld_sas_bld.f90
+287
View File
@@ -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
mlprec/mld_sbaseprec_aply.f90
+189
View File
@@ -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
mlprec/mld_sbaseprec_bld.f90
+217
View File
@@ -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
mlprec/mld_sdiag_bld.f90
+159
View File
@@ -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
mlprec/mld_sfact_bld.f90
+484
View File
@@ -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
mlprec/mld_silu0_fact.f90
+648
View File
@@ -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
mlprec/mld_silu_bld.f90
+280
View File
@@ -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
mlprec/mld_siluk_fact.f90
+971
View File
@@ -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.(k<i)) then
!
! Note: since U is scaled while copying it out (see iluk_copyout),
! we can use rwk in the update below
!
rwk = row(k)
row(k) = row(k) * d(k) ! d(k) == 1/a(k,k)
lrwk = rowlevs(k)
do jj=uia2(k),uia2(k+1)-1
j = uia1(jj)
if (j<=k) then
info = -i
return
endif
!
! Insert the index into the heap for further processing.
! The fill levels are initialized to a negative value. If we find
! one, it means that it is an as yet untouched index, so we need
! to insert it; otherwise it is already on the heap, there is no
! need to insert it more than once.
!
if (rowlevs(j)<0) then
call psb_insert_heap(j,heap,info)
if (info /= 0) return
rowlevs(j) = abs(rowlevs(j))
end if
!
! Update row(j) and the corresponding fill level
!
row(j) = row(j) - rwk * uaspk(jj)
rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1)
end do
end if
end do
end subroutine iluk_fact
!
! Subroutine: iluk_copyout
! Version: real
! Note: internal subroutine of mld_siluk_fact
!
! This routine copies a matrix row, computed by iluk_fact by applying an
! elimination step of the ILU(k) factorization, into the arrays laspk, uaspk,
! d, corresponding to the L factor, the U factor and the diagonal of U,
! respectively.
!
! Note that
! - the part of the row stored into uaspk is scaled by the corresponding diagonal
! entry, according to the LDU form of the incomplete factorization;
! - the inverse of the diagonal entries of U is actually stored into d; this is
! then managed in the solve stage associated to the ILU(k)/MILU(k) factorization;
! - if the MILU(k) factorization has been required (ialg == mld_milu_n_), the
! row entries discarded because their fill levels are too high are added to
! the diagonal entry of the row;
! - the row entries are stored in laspk and uaspk according to the CSR format;
! - the arrays row and rowlevs are re-initialized for future use in mld_iluk_fact
! (see also iluk_copyin and iluk_fact).
!
! This routine is used by mld_siluk_factint in the computation of the
! ILU(k)/MILU(k) factorization of a local sparse matrix.
!
!
! Arguments:
! fill_in - integer, input.
! The fill-in level k in ILU(k)/MILU(k).
! ialg - integer, input.
! The type of incomplete factorization considered. The MILU(k)
! factorization is computed if ialg = 2 (= mld_milu_n_); the
! ILU(k) factorization otherwise.
! i - integer, input.
! The local index of the row to be copied.
! m - integer, input.
! The number of rows of the local matrix under factorization.
! row - real(psb_spk_), dimension(:), input/output.
! It contains, input, the row to be copied, and, in output,
! the null vector (the latter is used in the next call to
! iluk_copyin in mld_iluk_fact).
! rowlevs - integer, dimension(:), input/output.
! In input rowlevs(k) contains the fill kevel of the k-th entry
! of the row to be copied. rowlevs(k) = -(m+1) indicates that
! this entry is zero; however, any rowlevs(k) = -(m+1) is not
! used by the routine. In output rowlevs(k) = -(m+1) for all k's
! (this is an inizialization for the next call to iluk_copyin
! in mld_iluk_factint).
! nidx - integer, input.
! The number of entries of the array row that have been examined
! during the elimination step carried out by the routine iluk_fact.
! idxs - integer, dimension(:), allocatable, input.
! The indices of the entries of the array row that have been
! examined during the elimination step carried out by the routine
! iluk_fact.
! l1 - integer, input/output.
! Pointer to the last occupied entry of laspk.
! l2 - integer, input/output.
! Pointer to the last occupied entry of uaspk.
! lia1 - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the L factor,
! copied in laspk row by row (see mld_siluk_factint), 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, copied in laspk row by row (see
! mld_siluk_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
! L factor are copied.
! d - real(psb_spk_), dimension(:), input/output.
! The array where the inverse of the diagonal entry of the
! row is copied (only d(i) is used by the routine).
! uia1 - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the U factor
! copied in uaspk row by row (see mld_siluk_factint), 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 copied in uaspk row by row (see
! mld_silu_fctint), according to the CSR storage format.
! uaspk - real(psb_spk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the
! U factor are copied.
! uplevs - integer, dimension(:), input.
! The fill levels of the nonzero entries in the part of the
! U factor above the current row.
!
subroutine iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,&
& l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,uplevs,info)
use psb_base_mod
implicit none
! Arguments
integer, intent(in) :: fill_in, ialg, i, m, nidx
integer, intent(inout) :: l1, l2, info
integer, intent(inout) :: rowlevs(:), idxs(:)
integer, allocatable, intent(inout) :: uia1(:), uia2(:), lia1(:), lia2(:),uplevs(:)
real(psb_spk_), allocatable, intent(inout) :: uaspk(:), laspk(:)
real(psb_spk_), intent(inout) :: row(:), d(:)
! Local variables
integer :: j,isz,err_act,int_err(5),idxp
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)
d(i) = szero
do idxp=1,nidx
j = idxs(idxp)
if (j<i) then
!
! Copy the lower part of the row
!
if (rowlevs(j) <= fill_in) then
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) = j
laspk(l1) = row(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)
else if (j==i) then
!
! Copy the diagonal entry of the row and re-initialize
! row(j) and rowlevs(j)
!
d(i) = d(i) + row(i)
row(i) = szero
rowlevs(i) = -(m+1)
else if (j>i) 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
mlprec/mld_silut_fact.f90
+1158
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_smlprec_aply.f90
+1435
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_smlprec_bld.f90
+180
View File
@@ -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
mlprec/mld_sprec_aply.f90
+260
View File
@@ -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
mlprec/mld_sprecbld.f90
+234
View File
@@ -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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
call init_baseprc_av(p%baseprecv(i),info)
if (debug_level >= 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
mlprec/mld_sprecfree.f90
+94
View File
@@ -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
mlprec/mld_sprecinit.f90
+252
View File
@@ -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
mlprec/mld_sprecset.f90
+637
View File
@@ -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
mlprec/mld_sslu_bld.f90
+129
View File
@@ -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
mlprec/mld_sslu_interface.c
+391
View File
@@ -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 <stdio.h>
#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
}
mlprec/mld_sslud_bld.f90
+148
View File
@@ -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
mlprec/mld_sslud_interface.c
+401
View File
@@ -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 <math.h>
#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 <stdio.h>
#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
}
mlprec/mld_ssp_renum.f90
+368
View File
@@ -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
mlprec/mld_ssub_aply.f90
+296
View File
@@ -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
mlprec/mld_ssub_solve.f90
+312
View File
@@ -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
mlprec/mld_sumf_bld.f90
+138
View File
@@ -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
mlprec/mld_sumf_interface.c
+258
View File
@@ -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 <stdio.h>
/* 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
}
mlprec/mld_zilu0_fact.f90
+1 -1
View File
@@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_dilu0_fact.f90
! File: mld_zilu0_fact.f90
!
! Subroutine: mld_zilu0_fact
! Version: complex
mlprec/mld_zmlprec_aply.f90
+7 -7
View File
@@ -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
mlprec/mld_zmlprec_bld.f90
+1 -1
View File
@@ -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
mlprec/mld_zprecset.f90
+6 -6
View File
@@ -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
test/fileread/Makefile
+25 -3
View File
@@ -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:
test/fileread/cf_sample.f90
+454
View File
@@ -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
test/fileread/data_input.f90
+91
View File
@@ -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
test/fileread/df_sample.f90
+11 -62
View File
@@ -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
test/fileread/runs/cfs.inp
+29
View File
@@ -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.
test/fileread/runs/dfs.inp
+6 -6
View File
@@ -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
test/fileread/runs/sfs.inp
+29
View File
@@ -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.
test/fileread/runs/zfs.inp
+29
View File
@@ -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.
test/fileread/sf_sample.f90
+454
View File
@@ -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
test/fileread/zf_sample.f90
+454
View File
@@ -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
test/pargen/Makefile
+5 -2
View File
@@ -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:
test/pargen/runs/ppde.inp
+5 -6
View File
@@ -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.
test/pargen/spde.f90
+795
View File
@@ -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<idim) then
val(element)=-b3(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x)*idim*idim+(y-1)*idim+(z)
element=element+1
endif
irow(1:element-1)=glob_row
ia=glob_row
t3 = psb_wtime()
call psb_spins(element-1,irow,icol,val,a,desc_a,info)
if(info /= 0) exit
tins = tins + (psb_wtime()-t3)
call psb_geins(1,(/ia/),zt(1:1),b,desc_a,info)
if(info /= 0) exit
zt(1)=0.d0
call psb_geins(1,(/ia/),zt(1:1),xv,desc_a,info)
if(info /= 0) exit
end if
end do
end do
call psb_barrier(ictxt)
t2 = psb_wtime()-t1
if(info /= 0) then
info=4010
ch_err='insert rout.'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
deallocate(val,irow,icol)
t1 = psb_wtime()
call psb_cdasb(desc_a,info)
call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)
call psb_barrier(ictxt)
tasb = psb_wtime()-t1
if(info /= 0) then
info=4010
ch_err='asb rout.'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_amx(ictxt,t2)
call psb_amx(ictxt,tins)
call psb_amx(ictxt,tasb)
if(iam == psb_root_) then
write(*,'("The matrix has been generated and assembeld in ",a3," format.")')&
& a%fida(1:3)
write(*,'("-pspins time : ",es10.4)')tins
write(*,'("-insert time : ",es10.4)')t2
write(*,'("-assembly time : ",es10.4)')tasb
end if
call psb_geasb(b,desc_a,info)
call psb_geasb(xv,desc_a,info)
if(info /= 0) then
info=4010
ch_err='asb rout.'
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 == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine create_matrix
end program spde
!
! functions parametrizing the differential equation
!
function a1(x,y,z)
use psb_base_mod, only : psb_spk_
real(psb_spk_) :: a1
real(psb_spk_) :: x,y,z
a1=1.e0
end function a1
function a2(x,y,z)
use psb_base_mod, only : psb_spk_
real(psb_spk_) :: a2
real(psb_spk_) :: x,y,z
a2=2.e1*y
end function a2
function a3(x,y,z)
use psb_base_mod, only : psb_spk_
real(psb_spk_) :: a3
real(psb_spk_) :: x,y,z
a3=1.e0
end function a3
function a4(x,y,z)
use psb_base_mod, only : psb_spk_
real(psb_spk_) :: a4
real(psb_spk_) :: x,y,z
a4=1.e0
end function a4
function b1(x,y,z)
use psb_base_mod, only : psb_spk_
real(psb_spk_) :: b1
real(psb_spk_) :: x,y,z
b1=1.e0
end function b1
function b2(x,y,z)
use psb_base_mod, only : psb_spk_
real(psb_spk_) :: b2
real(psb_spk_) :: x,y,z
b2=1.e0
end function b2
function b3(x,y,z)
use psb_base_mod, only : psb_spk_
real(psb_spk_) :: b3
real(psb_spk_) :: x,y,z
b3=1.e0
end function b3