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

mld2p4-2:

Browse Source 
config/pac.m4
 configure
 mlprec/Makefile
 mlprec/mld_base_prec_type.f90
 mlprec/mld_c_as_smoother.f90
 mlprec/mld_c_id_solver.f90
 mlprec/mld_c_ilu_solver.f90
 mlprec/mld_c_inner_mod.f90
 mlprec/mld_c_jac_smoother.f90
 mlprec/mld_c_move_alloc_mod.f90
 mlprec/mld_c_prec_mod.f90
 mlprec/mld_c_prec_type.f90
 mlprec/mld_c_slu_solver.f90
 mlprec/mld_caggrmap_bld.f90
 mlprec/mld_caggrmat_asb.f90
 mlprec/mld_caggrmat_nosmth_asb.F90
 mlprec/mld_caggrmat_smth_asb.F90
 mlprec/mld_ccoarse_bld.f90
 mlprec/mld_cilu0_fact.f90
 mlprec/mld_ciluk_fact.f90
 mlprec/mld_cilut_fact.f90
 mlprec/mld_cmlprec_aply.f90
 mlprec/mld_cmlprec_bld.f90
 mlprec/mld_cprecaply.f90
 mlprec/mld_cprecbld.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_csp_renum.f90
 mlprec/mld_cumf_bld.f90
 mlprec/mld_d_as_smoother.f90
 mlprec/mld_d_id_solver.f90
 mlprec/mld_d_ilu_solver.f90
 mlprec/mld_d_inner_mod.f90
 mlprec/mld_d_move_alloc_mod.f90
 mlprec/mld_d_prec_mod.f90
 mlprec/mld_d_prec_type.f90
 mlprec/mld_d_slu_solver.f90
 mlprec/mld_d_sludist_solver.f90
 mlprec/mld_d_umf_solver.f90
 mlprec/mld_daggrmap_bld.f90
 mlprec/mld_daggrmat_asb.f90
 mlprec/mld_daggrmat_minnrg_asb.F90
 mlprec/mld_daggrmat_nosmth_asb.F90
 mlprec/mld_daggrmat_smth_asb.F90
 mlprec/mld_dcoarse_bld.f90
 mlprec/mld_dilu0_fact.f90
 mlprec/mld_diluk_fact.f90
 mlprec/mld_dilut_fact.f90
 mlprec/mld_dmlprec_aply.f90
 mlprec/mld_dmlprec_bld.f90
 mlprec/mld_dprecaply.f90
 mlprec/mld_dprecbld.f90
 mlprec/mld_dprecinit.F90
 mlprec/mld_dprecset.F90
 mlprec/mld_dslu_bld.f90
 mlprec/mld_dslu_interface.c
 mlprec/mld_dslud_bld.f90
 mlprec/mld_dslud_interface.c
 mlprec/mld_dsp_renum.f90
 mlprec/mld_dumf_interface.c
 mlprec/mld_inner_mod.f90
 mlprec/mld_move_alloc_mod.f90
 mlprec/mld_prec_mod.f90
 mlprec/mld_s_as_smoother.f90
 mlprec/mld_s_id_solver.f90
 mlprec/mld_s_ilu_solver.f90
 mlprec/mld_s_inner_mod.f90
 mlprec/mld_s_jac_smoother.f90
 mlprec/mld_s_move_alloc_mod.f90
 mlprec/mld_s_prec_mod.f90
 mlprec/mld_s_prec_type.f90
 mlprec/mld_s_slu_solver.f90
 mlprec/mld_saggrmap_bld.f90
 mlprec/mld_saggrmat_asb.f90
 mlprec/mld_saggrmat_nosmth_asb.F90
 mlprec/mld_saggrmat_smth_asb.F90
 mlprec/mld_scoarse_bld.f90
 mlprec/mld_silu0_fact.f90
 mlprec/mld_siluk_fact.f90
 mlprec/mld_silut_fact.f90
 mlprec/mld_smlprec_aply.f90
 mlprec/mld_smlprec_bld.f90
 mlprec/mld_sprecaply.f90
 mlprec/mld_sprecbld.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_ssp_renum.f90
 mlprec/mld_sumf_bld.f90
 mlprec/mld_z_as_smoother.f90
 mlprec/mld_z_id_solver.f90
 mlprec/mld_z_ilu_solver.f90
 mlprec/mld_z_inner_mod.f90
 mlprec/mld_z_jac_smoother.f90
 mlprec/mld_z_move_alloc_mod.f90
 mlprec/mld_z_prec_mod.f90
 mlprec/mld_z_prec_type.f90
 mlprec/mld_z_slu_solver.f90
 mlprec/mld_z_umf_solver.f90
 mlprec/mld_zaggrmap_bld.f90
 mlprec/mld_zaggrmat_asb.f90
 mlprec/mld_zaggrmat_nosmth_asb.F90
 mlprec/mld_zaggrmat_smth_asb.F90
 mlprec/mld_zas_aply.f90
 mlprec/mld_zas_bld.f90
 mlprec/mld_zbaseprec_aply.f90
 mlprec/mld_zbaseprec_bld.f90
 mlprec/mld_zcoarse_bld.f90
 mlprec/mld_zdiag_bld.f90
 mlprec/mld_zfact_bld.f90
 mlprec/mld_zilu0_fact.f90
 mlprec/mld_zilu_bld.f90
 mlprec/mld_ziluk_fact.f90
 mlprec/mld_zilut_fact.f90
 mlprec/mld_zmlprec_aply.f90
 mlprec/mld_zmlprec_bld.f90
 mlprec/mld_zprecaply.f90
 mlprec/mld_zprecbld.f90
 mlprec/mld_zprecinit.F90
 mlprec/mld_zprecset.F90
 mlprec/mld_zslu_bld.f90
 mlprec/mld_zslu_interface.c
 mlprec/mld_zslud_bld.f90
 mlprec/mld_zsp_renum.f90
 mlprec/mld_zumf_bld.f90
 tests/newslv
 tests/newslv/Makefile
 tests/newslv/data_input.f90
 tests/newslv/mld_d_tlu_solver.f90
 tests/newslv/ppde.f90
 tests/newslv/runs
 tests/newslv/runs/ppde.inp
 tests/newslv/spde.f90
 tests/pdegen/ppde.f90
 tests/pdegen/runs/ppde.inp


Merged from newset branch.
This commit is contained in:
Salvatore Filippone
2011-03-02 10:36:11 +00:00
parent 439388f31e
commit 01ef87b4ed
138 changed files with 13825 additions and 7387 deletions
Download Patch File Download Diff File Expand all files Collapse all files
config/pac.m4
+58 -18
View File
@@ -774,9 +774,9 @@ dnl @author Salvatore Filippone <salvatore.filippone@uniroma2.it>
dnl
AC_DEFUN(PAC_CHECK_SUPERLU,
[AC_ARG_WITH(superlu, AC_HELP_STRING([--with-superlu=LIBNAME], [Specify the library name for SUPERLU library.
Default: "-lslu"]),
Default: "-lsuperlu"]),
[mld2p4_cv_superlu=$withval],
[mld2p4_cv_superlu='-lslu'])
[mld2p4_cv_superlu='-lsuperlu'])
AC_ARG_WITH(superludir, AC_HELP_STRING([--with-superludir=DIR], [Specify the directory for SUPERLU library and includes.]),
[mld2p4_cv_superludir=$withval],
[mld2p4_cv_superludir=''])
@@ -791,16 +791,35 @@ LIBS="$SLU_LIBS $LIBS"
CPPFLAGS="$SLU_INCLUDES $CPPFLAGS"
AC_MSG_NOTICE([slu dir $mld2p4_cv_superludir])
AC_CHECK_HEADER([slu_ddefs.h],
[pac_slu_header_ok=yes],
[pac_slu_header_ok=no; SLU_INCLUDES=""])
[pac_slu_header_ok=yes],
[pac_slu_header_ok=no; SLU_INCLUDES=""])
if test "x$pac_slu_header_ok" == "xno" ; then
dnl Maybe Include or include subdirs?
unset ac_cv_header_slu_ddefs_h
SLU_INCLUDES="-I$mld2p4_cv_superludir/include -I$mld2p4_cv_superludir/Include "
CPPFLAGS="$SLU_INCLUDES $SAVE_CPPFLAGS"
AC_CHECK_HEADER([slu_ddefs.h],
[pac_slu_header_ok=yes],
[pac_slu_header_ok=no; SLU_INCLUDES=""])
fi
if test "x$pac_slu_header_ok" == "xyes" ; then
SLU_LIBS="$mld2p4_cv_superlu $SLU_LIBS"
LIBS="$SLU_LIBS -lm $LIBS";
AC_MSG_CHECKING([for superlu_malloc in $SLU_LIBS])
AC_TRY_LINK_FUNC(superlu_malloc,
[mld2p4_cv_have_superlu=yes;pac_slu_lib_ok=yes;],
[mld2p4_cv_have_superlu=no;pac_slu_lib_ok=no; SLU_LIBS=""; SLU_INCLUDES=""])
AC_MSG_RESULT($pac_slu_lib_ok)
SLU_LIBS="$mld2p4_cv_superlu $SLU_LIBS"
LIBS="$SLU_LIBS -lm $LIBS";
AC_MSG_CHECKING([for superlu_malloc in $SLU_LIBS])
AC_TRY_LINK_FUNC(superlu_malloc,
[mld2p4_cv_have_superlu=yes;pac_slu_lib_ok=yes;],
[mld2p4_cv_have_superlu=no;pac_slu_lib_ok=no; SLU_LIBS=""; ])
if test "x$pac_slu_lib_ok" == "xno" ; then
dnl Maybe lib?
SLU_LIBS="$mld2p4_cv_superlu -L$mld2p4_cv_superludir/lib";
LIBS="$SLU_LIBS -lm $SAVE_LIBS";
AC_TRY_LINK_FUNC(superlu_malloc,
[mld2p4_cv_have_superlu=yes;pac_slu_lib_ok=yes;],
[mld2p4_cv_have_superlu=no;pac_slu_lib_ok=no; SLU_LIBS=""; SLU_INCLUDES=""])
fi
AC_MSG_RESULT($pac_slu_lib_ok)
fi
LIBS="$SAVE_LIBS";
CPPFLAGS="$SAVE_CPPFLAGS";
@@ -821,9 +840,9 @@ dnl
dnl @author Salvatore Filippone <salvatore.filippone@uniroma2.it>
dnl
AC_DEFUN(PAC_CHECK_SUPERLUDIST,
[AC_ARG_WITH(superludist, AC_HELP_STRING([--with-superludist=LIBNAME], [Specify the libname for SUPERLUDIST library. Requires you also specify SuperLU. Default: "-lslud"]),
[AC_ARG_WITH(superludist, AC_HELP_STRING([--with-superludist=LIBNAME], [Specify the libname for SUPERLUDIST library. Requires you also specify SuperLU. Default: "-lsuperlu_dist"]),
[mld2p4_cv_superludist=$withval],
[mld2p4_cv_superludist='-lslud'])
[mld2p4_cv_superludist='-lsuperlu_dist'])
AC_ARG_WITH(superludistdir, AC_HELP_STRING([--with-superludistdir=DIR], [Specify the directory for SUPERLUDIST library and includes.]),
[mld2p4_cv_superludistdir=$withval],
[mld2p4_cv_superludistdir=''])
@@ -843,6 +862,17 @@ 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=""])
if test "x$pac_sludist_header_ok" == "xno" ; then
dnl Maybe Include or include subdirs?
unset ac_cv_header_superlu_ddefs_h
SLUDIST_INCLUDES="-I$mld2p4_cv_superludistdir/include -I$mld2p4_cv_superludistdir/Include "
CPPFLAGS="$SLUDIST_INCLUDES $SAVE_CPPFLAGS"
AC_CHECK_HEADER([superlu_ddefs.h],
[pac_sludist_header_ok=yes],
[pac_sludist_header_ok=no; SLUDIST_INCLUDES=""])
fi
if test "x$pac_sludist_header_ok" == "xyes" ; then
SLUDIST_LIBS="$mld2p4_cv_superludist $SLUDIST_LIBS"
LIBS="$SLUDIST_LIBS -lm $LIBS";
@@ -850,12 +880,22 @@ if test "x$pac_sludist_header_ok" == "xyes" ; then
AC_TRY_LINK_FUNC(superlu_malloc_dist,
[mld2p4_cv_have_superludist=yes;pac_sludist_lib_ok=yes;],
[mld2p4_cv_have_superludist=no;pac_sludist_lib_ok=no;
SLUDIST_LIBS=""; SLUDIST_INCLUDES=""])
AC_MSG_RESULT($pac_sludist_lib_ok)
SLUDIST_LIBS=""; ])
if test "x$pac_sludist_lib_ok" == "xno" ; then
dnl Maybe lib?
SLUDIST_LIBS="$mld2p4_cv_superludist -L$mld2p4_cv_superludistdir/lib";
LIBS="$SLUDIST_LIBS -lm $SAVE_LIBS";
AC_TRY_LINK_FUNC(superlu_malloc_dist,
[mld2p4_cv_have_superludist=yes;pac_sludist_lib_ok=yes;],
[mld2p4_cv_have_superludist=no;pac_sludist_lib_ok=no;
SLUDIST_LIBS="";SLUDIST_INCLUDES=""])
fi
AC_MSG_RESULT($pac_sludist_lib_ok)
fi
LIBS="$save_LIBS";
CPPFLAGS="$save_CPPFLAGS";
CC="$save_CC";
LIBS="$save_LIBS";
CPPFLAGS="$save_CPPFLAGS";
CC="$save_CC";
])dnl
dnl @synopsis PAC_ARG_SERIAL_MPI
configure
Vendored
+105 -14
View File
@@ -1325,12 +1325,13 @@ Optional Packages:
--with-umfpackdir=DIR Specify the directory for UMFPACK library and
includes.
--with-superlu=LIBNAME Specify the library name for SUPERLU library.
Default: "-lslu"
Default: "-lsuperlu"
--with-superludir=DIR Specify the directory for SUPERLU library and
includes.
--with-superludist=LIBNAME
Specify the libname for SUPERLUDIST library.
Requires you also specify SuperLU. Default: "-lslud"
Requires you also specify SuperLU. Default:
"-lsuperlu_dist"
--with-superludistdir=DIR
Specify the directory for SUPERLUDIST library and
includes.
@@ -4987,7 +4988,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test "${with_superlu+set}" = set; then :
withval=$with_superlu; mld2p4_cv_superlu=$withval
else
mld2p4_cv_superlu='-lslu'
mld2p4_cv_superlu='-lsuperlu'
fi
@@ -5022,12 +5023,55 @@ else
fi
if test "x$pac_slu_header_ok" == "xno" ; then
unset ac_cv_header_slu_ddefs_h
SLU_INCLUDES="-I$mld2p4_cv_superludir/include -I$mld2p4_cv_superludir/Include "
CPPFLAGS="$SLU_INCLUDES $SAVE_CPPFLAGS"
ac_fn_c_check_header_mongrel "$LINENO" "slu_ddefs.h" "ac_cv_header_slu_ddefs_h" "$ac_includes_default"
if test "x$ac_cv_header_slu_ddefs_h" = x""yes; then :
pac_slu_header_ok=yes
else
pac_slu_header_ok=no; SLU_INCLUDES=""
fi
fi
if test "x$pac_slu_header_ok" == "xyes" ; then
SLU_LIBS="$mld2p4_cv_superlu $SLU_LIBS"
LIBS="$SLU_LIBS -lm $LIBS";
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for superlu_malloc in $SLU_LIBS" >&5
SLU_LIBS="$mld2p4_cv_superlu $SLU_LIBS"
LIBS="$SLU_LIBS -lm $LIBS";
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for superlu_malloc in $SLU_LIBS" >&5
$as_echo_n "checking for superlu_malloc in $SLU_LIBS... " >&6; }
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char superlu_malloc ();
int
main ()
{
return superlu_malloc ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
mld2p4_cv_have_superlu=yes;pac_slu_lib_ok=yes;
else
mld2p4_cv_have_superlu=no;pac_slu_lib_ok=no; SLU_LIBS="";
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
if test "x$pac_slu_lib_ok" == "xno" ; then
SLU_LIBS="$mld2p4_cv_superlu -L$mld2p4_cv_superludir/lib";
LIBS="$SLU_LIBS -lm $SAVE_LIBS";
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
@@ -5052,7 +5096,8 @@ else
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_slu_lib_ok" >&5
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_slu_lib_ok" >&5
$as_echo "$pac_slu_lib_ok" >&6; }
fi
LIBS="$SAVE_LIBS";
@@ -5070,7 +5115,7 @@ fi
if test "${with_superludist+set}" = set; then :
withval=$with_superludist; mld2p4_cv_superludist=$withval
else
mld2p4_cv_superludist='-lslud'
mld2p4_cv_superludist='-lsuperlu_dist'
fi
@@ -5108,6 +5153,21 @@ else
fi
if test "x$pac_sludist_header_ok" == "xno" ; then
unset ac_cv_header_superlu_ddefs_h
SLUDIST_INCLUDES="-I$mld2p4_cv_superludistdir/include -I$mld2p4_cv_superludistdir/Include "
CPPFLAGS="$SLUDIST_INCLUDES $SAVE_CPPFLAGS"
ac_fn_c_check_header_mongrel "$LINENO" "superlu_ddefs.h" "ac_cv_header_superlu_ddefs_h" "$ac_includes_default"
if test "x$ac_cv_header_superlu_ddefs_h" = x""yes; then :
pac_sludist_header_ok=yes
else
pac_sludist_header_ok=no; SLUDIST_INCLUDES=""
fi
fi
if test "x$pac_sludist_header_ok" == "xyes" ; then
SLUDIST_LIBS="$mld2p4_cv_superludist $SLUDIST_LIBS"
LIBS="$SLUDIST_LIBS -lm $LIBS";
@@ -5135,16 +5195,47 @@ if ac_fn_c_try_link "$LINENO"; then :
mld2p4_cv_have_superludist=yes;pac_sludist_lib_ok=yes;
else
mld2p4_cv_have_superludist=no;pac_sludist_lib_ok=no;
SLUDIST_LIBS=""; SLUDIST_INCLUDES=""
SLUDIST_LIBS="";
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_sludist_lib_ok" >&5
if test "x$pac_sludist_lib_ok" == "xno" ; then
SLUDIST_LIBS="$mld2p4_cv_superludist -L$mld2p4_cv_superludistdir/lib";
LIBS="$SLUDIST_LIBS -lm $SAVE_LIBS";
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char superlu_malloc_dist ();
int
main ()
{
return superlu_malloc_dist ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
mld2p4_cv_have_superludist=yes;pac_sludist_lib_ok=yes;
else
mld2p4_cv_have_superludist=no;pac_sludist_lib_ok=no;
SLUDIST_LIBS="";SLUDIST_INCLUDES=""
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_sludist_lib_ok" >&5
$as_echo "$pac_sludist_lib_ok" >&6; }
fi
LIBS="$save_LIBS";
CPPFLAGS="$save_CPPFLAGS";
CC="$save_CC";
LIBS="$save_LIBS";
CPPFLAGS="$save_CPPFLAGS";
CC="$save_CC";
if test "x$mld2p4_cv_have_superludist" == "xyes" ; then
SLUDIST_FLAGS="-DHave_SLUDist_ $SLUDIST_INCLUDES"
mlprec/Makefile
+85 -40
View File
@@ -7,38 +7,61 @@ HERE=.
FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR)
MODOBJS=mld_base_prec_type.o \
mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o \
mld_prec_type.o mld_prec_mod.o mld_inner_mod.o mld_move_alloc_mod.o\
mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \
mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \
mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \
mld_z_ilu_solver.o mld_z_diag_solver.o mld_z_jac_smoother.o mld_z_as_smoother.o \
mld_d_umf_solver.o mld_z_umf_solver.o
MPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o \
mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o \
mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o \
mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o
SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_move_alloc_mod.o \
mld_s_inner_mod.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \
mld_s_id_solver.o mld_s_slu_solver.o
DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_move_alloc_mod.o \
mld_d_inner_mod.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \
mld_d_umf_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o mld_d_id_solver.o
CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_move_alloc_mod.o \
mld_c_inner_mod.o mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \
mld_c_id_solver.o mld_c_slu_solver.o
ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_move_alloc_mod.o \
mld_z_inner_mod.o mld_z_ilu_solver.o mld_z_diag_solver.o mld_z_jac_smoother.o mld_z_as_smoother.o \
mld_z_id_solver.o mld_z_umf_solver.o mld_z_slu_solver.o
MODOBJS=mld_base_prec_type.o mld_prec_type.o mld_prec_mod.o \
$(SMODOBJS) $(DMODOBJS) $(CMODOBJS) $(ZMODOBJS)
SMPFOBJS=mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o
DMPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o
CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o
ZMPFOBJS=mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o
MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS)
MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o
INNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_dslu_bld.o \
mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \
mld_dmlprec_aply.o mld_dslud_bld.o mld_daggrmat_asb.o \
mld_scoarse_bld.o mld_smlprec_bld.o mld_sslu_bld.o mld_sumf_bld.o \
SINNEROBJS= mld_scoarse_bld.o mld_smlprec_bld.o \
mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \
mld_smlprec_aply.o mld_sslud_bld.o mld_saggrmat_asb.o \
mld_ccoarse_bld.o mld_cmlprec_bld.o mld_cslu_bld.o mld_cumf_bld.o \
mld_smlprec_aply.o mld_saggrmat_asb.o \
$(SMPFOBJS)
DINNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o \
mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \
mld_dmlprec_aply.o mld_daggrmat_asb.o \
$(DMPFOBJS)
CINNEROBJS= mld_ccoarse_bld.o mld_cmlprec_bld.o \
mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \
mld_cmlprec_aply.o mld_cslud_bld.o mld_caggrmat_asb.o \
mld_zcoarse_bld.o mld_zmlprec_bld.o mld_zslu_bld.o mld_zumf_bld.o \
mld_cmlprec_aply.o mld_caggrmat_asb.o \
$(CMPFOBJS)
ZINNEROBJS= mld_zcoarse_bld.o mld_zmlprec_bld.o \
mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \
mld_zmlprec_aply.o mld_zslud_bld.o mld_zaggrmat_asb.o \
$(MPFOBJS)
mld_zmlprec_aply.o mld_zaggrmat_asb.o \
$(ZMPFOBJS)
INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS)
OUTEROBJS=mld_dprecbld.o mld_dprecset.o mld_dprecinit.o mld_dprecaply.o \
mld_sprecbld.o mld_sprecset.o mld_sprecinit.o mld_sprecaply.o \
mld_cprecbld.o mld_cprecset.o mld_cprecinit.o mld_cprecaply.o \
mld_zprecbld.o mld_zprecset.o mld_zprecinit.o mld_zprecaply.o
SOUTEROBJS=mld_sprecbld.o mld_sprecset.o mld_sprecinit.o mld_sprecaply.o
DOUTEROBJS=mld_dprecbld.o mld_dprecset.o mld_dprecinit.o mld_dprecaply.o
COUTEROBJS=mld_cprecbld.o mld_cprecset.o mld_cprecinit.o mld_cprecaply.o
ZOUTEROBJS=mld_zprecbld.o mld_zprecset.o mld_zprecinit.o mld_zprecaply.o
OUTEROBJS=$(SOUTEROBJS) $(DOUTEROBJS) $(COUTEROBJS) $(ZOUTEROBJS)
F90OBJS=$(OUTEROBJS) $(INNEROBJS)
@@ -46,32 +69,54 @@ 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)
OBJS=$(F90OBJS) $(MODOBJS) $(COBJS) $(MPCOBJS)
LIBMOD=mld_prec_mod$(.mod)
LOCAL_MODS=$(LIBMOD) mld_prec_type$(.mod) mld_inner_mod$(.mod) mld_move_alloc_mod$(.mod) \
mld_base_prec_type$(.mod) mld_s_prec_type$(.mod) mld_d_prec_type$(.mod)\
mld_c_prec_type$(.mod) mld_z_prec_type$(.mod) mld_d_as_smoother$(.mod) \
mld_d_jac_smoother$(.mod) mld_d_diag_solver$(.mod) mld_d_ilu_solver$(.mod)
LOCAL_MODS=$(MODOBJS:.o=$(.mod))
LIBNAME=libmld_prec.a
lib: mpobjs $(OBJS)
lib: $(OBJS)
$(AR) $(HERE)/$(LIBNAME) $(OBJS)
$(RANLIB) $(HERE)/$(LIBNAME)
/bin/cp -p $(HERE)/$(LIBNAME) $(LIBDIR)
/bin/cp -p $(LIBMOD) $(LOCAL_MODS) $(LIBDIR)
$(F90OBJS) $(MPFOBJS): $(MODOBJS:.o=$(.mod))
mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o : mld_base_prec_type.o
mld_prec_type.o: mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o
mld_prec_mod.o mld_innner_mod.o: mld_prec_type.o
mld_inner_mod.o: mld_move_alloc_mod.o
mld_move_alloc_mod.o: mld_prec_type.o
mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_prec_type.o
mld_prec_mod.o: mld_prec_type.o mld_s_prec_mod.o mld_d_prec_mod.o mld_c_prec_mod.o mld_z_prec_mod.o
$(MODOBJS): $(PSBINCDIR)/psb_sparse_mod$(.mod)
$(SINNEROBJS) $(SOUTEROBJS): $(SMODOBJS)
$(DINNEROBJS) $(DOUTEROBJS): $(DMODOBJS)
$(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS)
$(ZINNEROBJS) $(ZOUTEROBJS): $(ZMODOBJS)
mld_s_inner_mod.o: mld_s_move_alloc_mod.o mld_s_prec_type.o
mld_d_inner_mod.o: mld_d_move_alloc_mod.o mld_d_prec_type.o
mld_c_inner_mod.o: mld_c_move_alloc_mod.o mld_c_prec_type.o
mld_z_inner_mod.o: mld_z_move_alloc_mod.o mld_z_prec_type.o
mld_s_move_alloc_mod.o: mld_s_prec_type.o
mld_d_move_alloc_mod.o: mld_d_prec_type.o
mld_c_move_alloc_mod.o: mld_c_prec_type.o
mld_z_move_alloc_mod.o: mld_z_prec_type.o
mld_s_prec_mod.o: mld_s_move_alloc_mod.o
mld_d_prec_mod.o: mld_d_move_alloc_mod.o
mld_c_prec_mod.o: mld_c_move_alloc_mod.o
mld_z_prec_mod.o: mld_z_move_alloc_mod.o
mld_d_sludist_solver.o mld_d_slu_solver.o mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_prec_type.o
mld_d_as_smoother.o mld_d_jac_smoother.o: mld_d_prec_type.o
mld_d_jac_smoother.o: mld_d_diag_solver.o
mld_dprecinit.o mld_dprecset.o: mld_d_diag_solver.o mld_d_ilu_solver.o \
mld_d_umf_solver.o mld_d_as_smoother.o mld_d_jac_smoother.o
mld_d_umf_solver.o mld_d_as_smoother.o mld_d_jac_smoother.o \
mld_d_id_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o
mld_z_umf_solver.o mld_z_diag_solver.o mld_z_ilu_solver.o: mld_z_prec_type.o
mld_z_as_smoother.o mld_z_jac_smoother.o: mld_z_prec_type.o
mld_z_jac_smoother.o: mld_z_diag_solver.o
@@ -83,14 +128,13 @@ mld_s_as_smoother.o mld_s_jac_smoother.o: mld_s_prec_type.o
mld_s_jac_smoother.o: mld_s_diag_solver.o
mld_sprecinit.o mld_sprecset.o: mld_s_diag_solver.o mld_s_ilu_solver.o \
mld_s_as_smoother.o mld_s_jac_smoother.o
mld_c_diag_solver.o mld_c_ilu_solver.o: mld_c_prec_type.o
mld_c_as_smoother.o mld_c_jac_smoother.o: mld_c_prec_type.o
mld_c_jac_smoother.o: mld_c_diag_solver.o
mld_cprecinit.o mld_cprecset.o: mld_c_diag_solver.o mld_c_ilu_solver.o \
mld_c_as_smoother.o mld_c_jac_smoother.o
$(MODOBJS): $(PSBINCDIR)/psb_sparse_mod$(.mod)
mpobjs: $(MODOBJS)
(make $(MPFOBJS) F90="$(MPF90)" F90COPT="$(F90COPT)")
@@ -101,3 +145,4 @@ veryclean: clean
clean:
/bin/rm -f $(OBJS) $(LOCAL_MODS)
mlprec/mld_base_prec_type.f90
+230 -19
View File
@@ -87,6 +87,28 @@ module mld_base_prec_type
type(mld_aux_onelev_map_type), allocatable :: mapv(:)
end type mld_aux_map_type
type mld_ml_parms
integer :: sweeps, sweeps_pre, sweeps_post
integer :: ml_type, smoother_pos
integer :: aggr_alg, aggr_kind
integer :: aggr_omega_alg, aggr_eig, aggr_filter
integer :: coarse_mat, coarse_solve
contains
procedure, pass(pm) :: descr => ml_parms_descr
end type mld_ml_parms
type, extends(mld_ml_parms) :: mld_sml_parms
real(psb_spk_) :: aggr_omega_val, aggr_thresh
contains
procedure, pass(pm) :: descr => s_ml_parms_descr
end type mld_sml_parms
type, extends(mld_ml_parms) :: mld_dml_parms
real(psb_dpk_) :: aggr_omega_val, aggr_thresh
contains
procedure, pass(pm) :: descr => d_ml_parms_descr
end type mld_dml_parms
!
! Entries in iprcparm
@@ -129,19 +151,21 @@ module mld_base_prec_type
!
! Legal values for entry: mld_smoother_type_
!
integer, parameter :: mld_min_prec_=0, mld_noprec_=0, mld_jac_=1, mld_bjac_=2,&
& mld_as_=3, mld_max_prec_=3
! VERY IMPORTANT: we are relying on the following to be true:
! mld_pjac_ == mld_diag_scale_
! mld_bjac_ == mld_milu_n_ (or mld_ilu_n_ would be fine)
! mld_diag_scale_ < min(mld_slu_ mld_umf_, mld_sludist_)
integer, parameter :: mld_min_prec_ = 0, mld_noprec_ = 0
integer, parameter :: mld_jac_ = 1, mld_bjac_ = 2
integer, parameter :: mld_as_ = 3, mld_max_prec_ = 3
!
! This is a quick&dirty fix, but I have nothing better now...
!
! Legal values for entry: mld_sub_solve_
!
integer, parameter :: mld_f_none_=0, mld_diag_scale_=1, mld_ilu_n_=2, mld_milu_n_=3
integer, parameter :: mld_ilu_t_=4, mld_slu_=5, mld_umf_=6, mld_sludist_=7
integer, parameter :: mld_max_sub_solve_= 7
integer, parameter :: mld_slv_delta_ = 4
integer, parameter :: mld_f_none_ = mld_slv_delta_+0, mld_diag_scale_ = mld_slv_delta_+1
integer, parameter :: mld_ilu_n_ = mld_slv_delta_+2, mld_milu_n_ = mld_slv_delta_+3
integer, parameter :: mld_ilu_t_ = mld_slv_delta_+4, mld_slu_ = mld_slv_delta_+5
integer, parameter :: mld_umf_ = mld_slv_delta_+6, mld_sludist_ = mld_slv_delta_+7
integer, parameter :: mld_max_sub_solve_= mld_slv_delta_+7
integer, parameter :: mld_min_sub_solve_= mld_diag_scale_
!
! Legal values for entry: mld_sub_ren_
!
@@ -151,8 +175,8 @@ module mld_base_prec_type
!
! Legal values for entry: mld_ml_type_
!
integer, parameter :: mld_no_ml_=0, mld_add_ml_=1, mld_mult_ml_=2
integer, parameter :: mld_new_ml_prec_=3, mld_max_ml_type_=mld_mult_ml_
integer, parameter :: mld_no_ml_ = 0, mld_add_ml_ = 1, mld_mult_ml_ = 2
integer, parameter :: mld_new_ml_prec_ = 3, mld_max_ml_type_ = mld_mult_ml_
!
! Legal values for entry: mld_smoother_pos_
!
@@ -161,8 +185,8 @@ module mld_base_prec_type
!
! Legal values for entry: mld_aggr_kind_
!
integer, parameter :: mld_no_smooth_=0, mld_smooth_prol_=1
integer, parameter :: mld_min_energy_=2, mld_biz_prol_=3
integer, parameter :: mld_no_smooth_ = 0, mld_smooth_prol_ = 1
integer, parameter :: mld_min_energy_ = 2, mld_biz_prol_ = 3
! Disabling biz_prol for the time being.
integer, parameter :: mld_max_aggr_kind_=mld_min_energy_
!
@@ -236,15 +260,22 @@ module mld_base_prec_type
& ml_names(0:3)=(/'none ','additive ','multiplicative',&
& 'new ML '/)
character(len=15), parameter, private :: &
& fact_names(0:7)=(/'none ','Point Jacobi ','ILU(n) ',&
& fact_names(0:mld_slv_delta_+7)=(/&
& 'none ','none ',&
& 'none ','none ',&
& 'none ', 'Point Jacobi ','ILU(n) ',&
& 'MILU(n) ','ILU(t,n) ',&
& 'UMFPACK LU ',&
& 'SuperLU_Dist ','SuperLU '/)
& 'SuperLU ','UMFPACK LU ',&
& 'SuperLU_Dist '/)
interface mld_check_def
module procedure mld_icheck_def, mld_scheck_def, mld_dcheck_def
end interface
interface psb_bcast
module procedure mld_ml_bcast, mld_sml_bcast, mld_dml_bcast
end interface psb_bcast
contains
!
@@ -322,8 +353,8 @@ contains
val = mld_twoside_smooth_
case('NOPREC')
val = mld_noprec_
!!$ case('DIAG')
!!$ val = mld_diag_
! !$ case('DIAG')
! !$ val = mld_diag_
case('BJAC')
val = mld_bjac_
case('JAC','JACOBI')
@@ -359,6 +390,132 @@ contains
!
! Routines printing out a description of the preconditioner
!
subroutine ml_parms_descr(pm,iout,info,coarse)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_ml_parms), intent(in) :: pm
integer, intent(in) :: iout
integer, intent(out) :: info
logical, intent(in), optional :: coarse
logical :: coarse_
info = psb_success_
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
if (coarse_) then
write(iout,*) ' Coarsest matrix: ',&
& matrix_names(pm%coarse_mat)
if (pm%coarse_solve == mld_bjac_) then
write(iout,*) ' Coarse solver: Block Jacobi '
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps
else
write(iout,*) ' Coarse solver: ',&
& fact_names(pm%coarse_solve)
endif
else
if (pm%ml_type>mld_no_ml_) then
write(iout,*) ' Multilevel type: ',&
& ml_names(pm%ml_type)
write(iout,*) ' Smoother position: ',&
& smooth_pos_names(pm%smoother_pos)
if (pm%ml_type == mld_add_ml_) then
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps
else
select case (pm%smoother_pos)
case (mld_pre_smooth_)
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps_pre
case (mld_post_smooth_)
write(iout,*) ' Number of sweeps : ',&
& pm%sweeps_post
case (mld_twoside_smooth_)
write(iout,*) ' Number of sweeps : pre: ',&
& pm%sweeps_pre ,&
& ' post: ',&
& pm%sweeps_post
end select
end if
if (pm%aggr_kind /= mld_no_smooth_) then
if (pm%aggr_omega_alg == mld_eig_est_) then
write(iout,*) ' Damping omega computation: spectral radius estimate'
write(iout,*) ' Spectral radius estimate: ', &
& eigen_estimates(pm%aggr_eig)
else if (pm%aggr_omega_alg == mld_user_choice_) then
write(iout,*) ' Damping omega computation: user defined value.'
else
write(iout,*) ' Damping omega computation: unknown value in iprcparm!!'
end if
end if
write(iout,*) ' Aggregation: ', &
& aggr_names(pm%aggr_alg)
write(iout,*) ' Aggregation type: ', &
& aggr_kinds(pm%aggr_kind)
end if
end if
return
end subroutine ml_parms_descr
subroutine s_ml_parms_descr(pm,iout,info,coarse)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_sml_parms), intent(in) :: pm
integer, intent(in) :: iout
integer, intent(out) :: info
logical, intent(in), optional :: coarse
info = psb_success_
call pm%mld_ml_parms%descr(iout,info,coarse)
write(iout,*) ' Aggregation threshold: ', &
& pm%aggr_thresh
return
end subroutine s_ml_parms_descr
subroutine d_ml_parms_descr(pm,iout,info,coarse)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_dml_parms), intent(in) :: pm
integer, intent(in) :: iout
integer, intent(out) :: info
logical, intent(in), optional :: coarse
info = psb_success_
call pm%mld_ml_parms%descr(iout,info,coarse)
write(iout,*) ' Aggregation threshold: ', &
& pm%aggr_thresh
return
end subroutine d_ml_parms_descr
subroutine mld_base_prec_descr(iout,iprcparm, info,rprcparm,dprcparm)
implicit none
@@ -815,9 +972,18 @@ contains
integer, intent(in) :: ip
logical :: is_legal_ml_fact
! Here the minimum is really 1, mld_fact_none_ is not acceptable.
is_legal_ml_fact = ((ip>=1).and.(ip<=mld_max_sub_solve_))
is_legal_ml_fact = ((ip>=mld_min_sub_solve_).and.(ip<=mld_max_sub_solve_))
return
end function is_legal_ml_fact
function is_legal_ilu_fact(ip)
implicit none
integer, intent(in) :: ip
logical :: is_legal_ilu_fact
is_legal_ilu_fact = ((ip==mld_ilu_n_).or.&
& (ip==mld_milu_n_).or.(ip==mld_ilu_t_))
return
end function is_legal_ilu_fact
function is_legal_ml_lev(ip)
implicit none
integer, intent(in) :: ip
@@ -957,5 +1123,50 @@ contains
end function pr_to_str
subroutine mld_ml_bcast(ictxt,dat,root)
use psb_sparse_mod
implicit none
integer, intent(in) :: ictxt
type(mld_ml_parms), intent(inout) :: dat
integer, intent(in), optional :: root
call psb_bcast(ictxt,dat%sweeps,root)
call psb_bcast(ictxt,dat%sweeps_pre,root)
call psb_bcast(ictxt,dat%sweeps_post,root)
call psb_bcast(ictxt,dat%ml_type,root)
call psb_bcast(ictxt,dat%smoother_pos,root)
call psb_bcast(ictxt,dat%aggr_alg,root)
call psb_bcast(ictxt,dat%aggr_kind,root)
call psb_bcast(ictxt,dat%aggr_omega_alg,root)
call psb_bcast(ictxt,dat%aggr_eig,root)
call psb_bcast(ictxt,dat%aggr_filter,root)
call psb_bcast(ictxt,dat%coarse_mat,root)
call psb_bcast(ictxt,dat%coarse_solve,root)
end subroutine mld_ml_bcast
subroutine mld_sml_bcast(ictxt,dat,root)
use psb_sparse_mod
implicit none
integer, intent(in) :: ictxt
type(mld_sml_parms), intent(inout) :: dat
integer, intent(in), optional :: root
call psb_bcast(ictxt,dat%mld_ml_parms,root)
call psb_bcast(ictxt,dat%aggr_omega_val,root)
call psb_bcast(ictxt,dat%aggr_thresh,root)
end subroutine mld_sml_bcast
subroutine mld_dml_bcast(ictxt,dat,root)
use psb_sparse_mod
implicit none
integer, intent(in) :: ictxt
type(mld_dml_parms), intent(inout) :: dat
integer, intent(in), optional :: root
call psb_bcast(ictxt,dat%mld_ml_parms,root)
call psb_bcast(ictxt,dat%aggr_omega_val,root)
call psb_bcast(ictxt,dat%aggr_thresh,root)
end subroutine mld_dml_bcast
end module mld_base_prec_type
mlprec/mld_c_as_smoother.f90
+128 -7
View File
@@ -53,8 +53,10 @@ module mld_c_as_smoother
!
type(psb_cspmat_type) :: nd
type(psb_desc_type) :: desc_data
integer :: novr, restr, prol
integer :: novr, restr, prol, nd_nnz_tot
contains
procedure, pass(sm) :: check => c_as_smoother_check
procedure, pass(sm) :: dump => c_as_smoother_dmp
procedure, pass(sm) :: build => c_as_smoother_bld
procedure, pass(sm) :: apply => c_as_smoother_apply
procedure, pass(sm) :: free => c_as_smoother_free
@@ -63,13 +65,16 @@ module mld_c_as_smoother
procedure, pass(sm) :: setr => c_as_smoother_setr
procedure, pass(sm) :: descr => c_as_smoother_descr
procedure, pass(sm) :: sizeof => c_as_smoother_sizeof
procedure, pass(sm) :: default => c_as_smoother_default
end type mld_c_as_smoother_type
private :: c_as_smoother_bld, c_as_smoother_apply, &
& c_as_smoother_free, c_as_smoother_seti, &
& c_as_smoother_setc, c_as_smoother_setr,&
& c_as_smoother_descr, c_as_smoother_sizeof
& c_as_smoother_descr, c_as_smoother_sizeof, &
& c_as_smoother_check, c_as_smoother_default,&
& c_as_smoother_dmp
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
@@ -79,6 +84,73 @@ module mld_c_as_smoother
contains
subroutine c_as_smoother_default(sm)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_as_smoother_type), intent(inout) :: sm
sm%restr = psb_halo_
sm%prol = psb_none_
sm%novr = 1
if (allocated(sm%sv)) then
call sm%sv%default()
end if
return
end subroutine c_as_smoother_default
subroutine c_as_smoother_check(sm,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_as_smoother_type), intent(inout) :: sm
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='c_as_smoother_check'
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(sm%restr,&
& 'Restrictor',psb_halo_,is_legal_restrict)
call mld_check_def(sm%prol,&
& 'Prolongator',psb_none_,is_legal_prolong)
call mld_check_def(sm%novr,&
& 'Overlap layers ',0,is_legal_n_ovr)
if (allocated(sm%sv)) then
call sm%sv%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_as_smoother_check
subroutine c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
@@ -100,6 +172,8 @@ contains
call psb_erractionsave(err_act)
info = psb_success_
ictxt = psb_cd_get_context(desc_data)
call psb_info (ictxt,me,np)
trans_ = psb_toupper(trans)
select case(trans_)
@@ -401,7 +475,7 @@ contains
! and Y(j) is the approximate solution at sweep j.
!
ww(1:n_row) = tx(1:n_row)
call psb_spmm(-cone,sm%nd,tx,cone,ww,sm%desc_data,info,work=aux,trans=trans_)
call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
@@ -525,7 +599,7 @@ contains
integer, intent(out) :: info
! Local variables
type(psb_cspmat_type) :: blck, atmp
integer :: n_row,n_col, nrow_a, nhalo, novr, data_
integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='c_as_smoother_bld', ch_err
@@ -631,6 +705,10 @@ contains
call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4')
goto 9999
end if
nzeros = sm%nd%get_nzeros()
!!$ write(0,*) me,' ND nzeors ',nzeros
call psb_sum(ictxt,nzeros)
sm%nd_nnz_tot = nzeros
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
@@ -677,9 +755,6 @@ contains
case default
if (allocated(sm%sv)) then
call sm%sv%set(what,val,info)
!!$ else
!!$ write(0,*) trim(name),' Missing component, not setting!'
!!$ info = 1121
end if
end select
@@ -871,4 +946,50 @@ contains
return
end function c_as_smoother_sizeof
subroutine c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
use psb_sparse_mod
implicit none
class(mld_c_as_smoother_type), intent(in) :: sm
integer, intent(in) :: ictxt,level
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver
integer :: i, j, il1, iln, lname, lev
integer :: icontxt,iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
logical :: smoother_
! len of prefix_
info = 0
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_smth_c"
end if
call psb_info(ictxt,iam,np)
if (present(smoother)) then
smoother_ = smoother
else
smoother_ = .false.
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
lname = lname + 5
if (smoother_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
if (sm%nd%is_asb()) &
& call sm%nd%print(fname,head=head)
end if
! At base level do nothing for the smoother
if (allocated(sm%sv)) &
& call sm%sv%dump(ictxt,level,info,solver=solver)
end subroutine c_as_smoother_dmp
end module mld_c_as_smoother
mlprec/mld_c_id_solver.f90
+280
View File
@@ -0,0 +1,280 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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.
!!$
!!$
!
!
!
! Identity solver. Reference for nullprec.
!
!
module mld_c_id_solver
use mld_c_prec_type
type, extends(mld_c_base_solver_type) :: mld_c_id_solver_type
contains
procedure, pass(sv) :: build => c_id_solver_bld
procedure, pass(sv) :: apply => c_id_solver_apply
procedure, pass(sv) :: free => c_id_solver_free
procedure, pass(sv) :: seti => c_id_solver_seti
procedure, pass(sv) :: setc => c_id_solver_setc
procedure, pass(sv) :: setr => c_id_solver_setr
procedure, pass(sv) :: descr => c_id_solver_descr
procedure, pass(sv) :: sizeof => c_id_solver_sizeof
end type mld_c_id_solver_type
private :: c_id_solver_bld, c_id_solver_apply, &
& c_id_solver_free, c_id_solver_seti, &
& c_id_solver_setc, c_id_solver_setr,&
& c_id_solver_descr, c_id_solver_sizeof
contains
subroutine c_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_c_id_solver_type), intent(in) :: sv
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
integer :: n_row,n_col
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='c_id_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_id_solver_apply
subroutine c_id_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_c_id_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_cspmat_type), intent(in), target, optional :: b
! Local variables
integer :: n_row,n_col, nrow_a, nztota
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='c_id_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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),' start'
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 == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_id_solver_bld
subroutine c_id_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='c_id_solver_seti'
info = psb_success_
return
end subroutine c_id_solver_seti
subroutine c_id_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='c_id_solver_setc'
info = psb_success_
return
end subroutine c_id_solver_setc
subroutine c_id_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='c_id_solver_setr'
info = psb_success_
return
end subroutine c_id_solver_setr
subroutine c_id_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_id_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='c_id_solver_free'
info = psb_success_
return
end subroutine c_id_solver_free
subroutine c_id_solver_descr(sv,info,iout)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_id_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_c_id_solver_descr'
integer :: iout_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' Identity local solver '
return
end subroutine c_id_solver_descr
function c_id_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_c_id_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 0
return
end function c_id_solver_sizeof
end module mld_c_id_solver
mlprec/mld_c_ilu_solver.f90
+130 -11
View File
@@ -53,6 +53,7 @@ module mld_c_ilu_solver
integer :: fact_type, fill_in
real(psb_spk_) :: thresh
contains
procedure, pass(sv) :: dump => c_ilu_solver_dmp
procedure, pass(sv) :: build => c_ilu_solver_bld
procedure, pass(sv) :: apply => c_ilu_solver_apply
procedure, pass(sv) :: free => c_ilu_solver_free
@@ -61,13 +62,15 @@ module mld_c_ilu_solver
procedure, pass(sv) :: setr => c_ilu_solver_setr
procedure, pass(sv) :: descr => c_ilu_solver_descr
procedure, pass(sv) :: sizeof => c_ilu_solver_sizeof
procedure, pass(sv) :: default => c_ilu_solver_default
end type mld_c_ilu_solver_type
private :: c_ilu_solver_bld, c_ilu_solver_apply, &
& c_ilu_solver_free, c_ilu_solver_seti, &
& c_ilu_solver_setc, c_ilu_solver_setr,&
& c_ilu_solver_descr, c_ilu_solver_sizeof
& c_ilu_solver_descr, c_ilu_solver_sizeof, &
& c_ilu_solver_default, c_ilu_solver_dmp
interface mld_ilu0_fact
@@ -109,13 +112,74 @@ module mld_c_ilu_solver
end interface
character(len=15), parameter, private :: &
& fact_names(0:4)=(/'none ','DIAG ?? ',&
& fact_names(0:mld_slv_delta_+4)=(/&
& 'none ','none ',&
& 'none ','none ',&
& 'none ','DIAG ?? ',&
& 'ILU(n) ',&
& 'MILU(n) ','ILU(t,n) '/)
contains
subroutine c_ilu_solver_default(sv)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_ilu_solver_type), intent(inout) :: sv
sv%fact_type = mld_ilu_n_
sv%fill_in = 0
sv%thresh = szero
return
end subroutine c_ilu_solver_default
subroutine c_ilu_solver_check(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_ilu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='c_ilu_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(sv%fact_type,&
& 'Factorization',mld_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(sv%fill_in,&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(sv%thresh,&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_ilu_solver_check
subroutine c_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
@@ -131,7 +195,7 @@ contains
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_ilu_solver_apply'
character(len=20) :: name='c_ilu_solver_apply'
call psb_erractionsave(err_act)
@@ -236,7 +300,7 @@ contains
integer :: n_row,n_col, nrow_a, nztota
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_ilu_solver_bld', ch_err
character(len=20) :: name='c_ilu_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
@@ -291,7 +355,8 @@ contains
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/))
call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/3,sv%fill_in,0,0,0/))
goto 9999
case(0:)
@@ -313,7 +378,8 @@ contains
select case(sv%fill_in)
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/))
call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/3,sv%fill_in,0,0,0/))
goto 9999
case(0)
! Fill-in 0
@@ -343,7 +409,9 @@ contains
case default
! If we end up here, something was wrong up in the call chain.
call psb_errpush(psb_err_alloc_dealloc_,name)
info = psb_err_input_value_invalid_i_
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/3,sv%fact_type,0,0,0/))
goto 9999
end select
@@ -399,7 +467,7 @@ contains
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_seti'
character(len=20) :: name='c_ilu_solver_seti'
info = psb_success_
call psb_erractionsave(err_act)
@@ -438,7 +506,7 @@ contains
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_ilu_solver_setc'
character(len=20) :: name='c_ilu_solver_setc'
info = psb_success_
call psb_erractionsave(err_act)
@@ -476,7 +544,7 @@ contains
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_setr'
character(len=20) :: name='c_ilu_solver_setr'
call psb_erractionsave(err_act)
info = psb_success_
@@ -512,7 +580,7 @@ contains
class(mld_c_ilu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_free'
character(len=20) :: name='c_ilu_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
@@ -603,4 +671,55 @@ contains
return
end function c_ilu_solver_sizeof
subroutine c_ilu_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
use psb_sparse_mod
implicit none
class(mld_c_ilu_solver_type), intent(in) :: sv
integer, intent(in) :: ictxt,level
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: solver
integer :: i, j, il1, iln, lname, lev
integer :: icontxt,iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
logical :: solver_
! len of prefix_
info = 0
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_slv_d"
end if
call psb_info(ictxt,iam,np)
if (present(solver)) then
solver_ = solver
else
solver_ = .false.
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
lname = lname + 5
if (solver_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_lower.mtx'
if (sv%l%is_asb()) &
& call sv%l%print(fname,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx'
if (allocated(sv%d)) &
& call psb_geprt(fname,sv%d,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_upper.mtx'
if (sv%u%is_asb()) &
& call sv%u%print(fname,head=head)
end if
end subroutine c_ilu_solver_dmp
end module mld_c_ilu_solver
mlprec/mld_c_inner_mod.f90
+141
View File
@@ -0,0 +1,141 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_inner_mod.f90
!
! Module: mld_inner_mod
!
! This module defines the interfaces to the real/complex, single/double
! precision versions of the MLD2P4 routines, except those of the user level,
! whose interfaces are defined in mld_prec_mod.f90.
!
module mld_c_inner_mod
use mld_c_prec_type
use mld_c_move_alloc_mod
interface mld_mlprec_bld
subroutine mld_cmlprec_bld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_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), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_cmlprec_bld
end interface mld_mlprec_bld
interface mld_mlprec_aply
subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_cprec_type), intent(in) :: p
complex(psb_spk_),intent(in) :: alpha,beta
complex(psb_spk_),intent(in) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
character,intent(in) :: trans
complex(psb_spk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_cmlprec_aply
end interface mld_mlprec_aply
interface mld_coarse_bld
subroutine mld_ccoarse_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_conelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_conelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_ccoarse_bld
end interface mld_coarse_bld
interface mld_aggrmap_bld
subroutine mld_caggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
integer, intent(in) :: aggr_type
real(psb_spk_), intent(in) :: theta
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
end subroutine mld_caggrmap_bld
end interface mld_aggrmap_bld
interface mld_aggrmat_asb
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_conelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_conelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_asb
end interface mld_aggrmat_asb
interface mld_aggrmat_nosmth_asb
subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_conelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_conelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_nosmth_asb
end interface mld_aggrmat_nosmth_asb
interface mld_aggrmat_smth_asb
subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_conelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_conelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_smth_asb
end interface mld_aggrmat_smth_asb
end module mld_c_inner_mod
mlprec/mld_c_jac_smoother.f90
+17 -8
View File
@@ -90,7 +90,7 @@ contains
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_jac_smoother_apply'
character(len=20) :: name='c_jac_smoother_apply'
call psb_erractionsave(err_act)
@@ -142,7 +142,8 @@ contains
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in sub_aply Jacobi Sweeps = 1')
call psb_errpush(psb_err_internal_error_,&
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
@@ -243,7 +244,7 @@ contains
integer :: n_row,n_col, nrow_a, nztota, nzeros
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_jac_smoother_bld', ch_err
character(len=20) :: name='c_jac_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
@@ -271,7 +272,15 @@ contains
if (info == psb_success_) &
& call sm%sv%build(a,desc_a,upd,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4')
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='clip & psb_spcnv csr 4')
goto 9999
end if
call sm%sv%build(a,desc_a,upd,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='solver build')
goto 9999
end if
nzeros = sm%nd%get_nzeros()
@@ -306,7 +315,7 @@ contains
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_jac_smoother_seti'
character(len=20) :: name='c_jac_smoother_seti'
info = psb_success_
call psb_erractionsave(err_act)
@@ -347,7 +356,7 @@ contains
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_jac_smoother_setc'
character(len=20) :: name='c_jac_smoother_setc'
info = psb_success_
call psb_erractionsave(err_act)
@@ -385,7 +394,7 @@ contains
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_jac_smoother_setr'
character(len=20) :: name='c_jac_smoother_setr'
call psb_erractionsave(err_act)
info = psb_success_
@@ -420,7 +429,7 @@ contains
class(mld_c_jac_smoother_type), intent(inout) :: sm
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_jac_smoother_free'
character(len=20) :: name='c_jac_smoother_free'
call psb_erractionsave(err_act)
info = psb_success_
mlprec/mld_c_move_alloc_mod.f90
+102
View File
@@ -0,0 +1,102 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_move_alloc_mod.f90
!
! Module: mld_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_c_move_alloc_mod
use mld_c_prec_type
interface mld_move_alloc
module procedure mld_conelev_prec_move_alloc,&
& mld_cprec_move_alloc
end interface
contains
subroutine mld_conelev_prec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_conelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call mld_precfree(b,info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_conelev_prec_move_alloc
subroutine mld_cprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_cprec_type), intent(inout) :: a
type(mld_cprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i,isz
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, isz
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_cprec_move_alloc
end module mld_c_move_alloc_mod
mlprec/mld_c_prec_mod.f90
+159
View File
@@ -0,0 +1,159 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_prec_mod.f90
!
! Module: mld_prec_mod
!
! This module defines the interfaces to the real/complex, single/double
! precision versions of the user-level MLD2P4 routines.
!
module mld_c_prec_mod
use mld_c_prec_type
use mld_c_move_alloc_mod
interface mld_precinit
subroutine mld_cprecinit(p,ptype,info,nlev)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_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
end interface
interface mld_precset
module procedure mld_i_cprecseti, mld_i_cprecsetc, mld_i_cprecsetr
end interface
interface mld_inner_precset
subroutine mld_cprecsetsm(p,what,val,info,ilev)
use mld_c_prec_type, only : mld_cprec_type, mld_c_base_smoother_type
type(mld_cprec_type), intent(inout) :: p
integer, intent(in) :: what
class(mld_c_base_smoother_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_cprecsetsm
subroutine mld_cprecsetsv(p,what,val,info,ilev)
use mld_c_prec_type, only : mld_cprec_type, mld_c_base_solver_type
type(mld_cprec_type), intent(inout) :: p
integer, intent(in) :: what
class(mld_c_base_solver_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_cprecsetsv
subroutine mld_cprecseti(p,what,val,info,ilev)
use mld_c_prec_type, only : mld_cprec_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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_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
end interface
interface mld_precbld
subroutine mld_cprecbld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_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), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_cprecbld
end interface
contains
subroutine mld_i_cprecseti(p,what,val,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_type
type(mld_cprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_cprecseti
subroutine mld_i_cprecsetr(p,what,val,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_type
type(mld_cprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_cprecsetr
subroutine mld_i_cprecsetc(p,what,val,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_cprec_type
type(mld_cprec_type), intent(inout) :: p
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_cprecsetc
end module mld_c_prec_mod
mlprec/mld_c_prec_type.f90
+503 -216
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_c_slu_solver.f90
+465
View File
@@ -0,0 +1,465 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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 mld_c_slu_solver
use iso_c_binding
use mld_c_prec_type
type, extends(mld_c_base_solver_type) :: mld_c_slu_solver_type
type(c_ptr) :: lufactors=c_null_ptr
integer(c_long_long) :: symbsize=0, numsize=0
contains
procedure, pass(sv) :: build => c_slu_solver_bld
procedure, pass(sv) :: apply => c_slu_solver_apply
procedure, pass(sv) :: free => c_slu_solver_free
procedure, pass(sv) :: seti => c_slu_solver_seti
procedure, pass(sv) :: setc => c_slu_solver_setc
procedure, pass(sv) :: setr => c_slu_solver_setr
procedure, pass(sv) :: descr => c_slu_solver_descr
procedure, pass(sv) :: sizeof => c_slu_solver_sizeof
end type mld_c_slu_solver_type
private :: c_slu_solver_bld, c_slu_solver_apply, &
& c_slu_solver_free, c_slu_solver_seti, &
& c_slu_solver_setc, c_slu_solver_setr,&
& c_slu_solver_descr, c_slu_solver_sizeof
interface
function mld_cslu_fact(n,nnz,values,rowptr,colind,&
& lufactors)&
& bind(c,name='mld_cslu_fact') result(info)
use iso_c_binding
integer(c_int), value :: n,nnz
integer(c_int) :: info
!integer(c_long_long) :: ssize, nsize
integer(c_int) :: rowptr(*),colind(*)
complex(c_float) :: values(*)
type(c_ptr) :: lufactors
end function mld_cslu_fact
end interface
interface
function mld_cslu_solve(itrans,n,x, b, ldb, lufactors)&
& bind(c,name='mld_cslu_solve') result(info)
use iso_c_binding
integer(c_int) :: info
integer(c_int), value :: itrans,n,ldb
complex(c_float) :: x(*), b(ldb,*)
type(c_ptr), value :: lufactors
end function mld_cslu_solve
end interface
interface
function mld_cslu_free(lufactors)&
& bind(c,name='mld_cslu_free') result(info)
use iso_c_binding
integer(c_int) :: info
type(c_ptr), value :: lufactors
end function mld_cslu_free
end interface
contains
subroutine c_slu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_c_slu_solver_type), intent(in) :: sv
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
integer :: n_row,n_col
complex(psb_spk_), pointer :: ww(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='c_slu_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N','T','C')
!Ok
case default
call psb_errpush(psb_err_iarg_invalid_i_,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)
else
allocate(ww(n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
endif
select case(trans_)
case('N')
info = mld_cslu_solve(0,n_row,ww,x,n_row,sv%lufactors)
case('T')
info = mld_cslu_solve(1,n_row,ww,x,n_row,sv%lufactors)
case('C')
info = mld_cslu_solve(2,n_row,ww,x,n_row,sv%lufactors)
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in subsolve')
goto 9999
endif
if (n_col > size(work)) then
deallocate(ww)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_slu_solver_apply
subroutine c_slu_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_c_slu_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_cspmat_type), intent(in), target, optional :: b
! Local variables
type(psb_cspmat_type) :: atmp
type(psb_c_csr_sparse_mat) :: acsr
integer :: n_row,n_col, nrow_a, nztota
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='c_slu_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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),' start'
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
if (psb_toupper(upd) == 'F') then
call a%cscnv(atmp,info,type='coo')
call psb_rwextd(n_row,atmp,info,b=b)
call atmp%cscnv(info,type='csr',dupl=psb_dupl_add_)
call atmp%mv_to(acsr)
nrow_a = acsr%get_nrows()
nztota = acsr%get_nzeros()
! Fix the entres to call C-base SuperLU
acsr%ja(:) = acsr%ja(:) - 1
acsr%irp(:) = acsr%irp(:) - 1
info = mld_cslu_fact(nrow_a,nztota,acsr%val,&
& acsr%irp,acsr%ja,sv%lufactors)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_cslu_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call acsr%free()
call atmp%free()
else
! ?
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
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 == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_slu_solver_bld
subroutine c_slu_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='c_slu_solver_seti'
info = psb_success_
call psb_erractionsave(err_act)
select case(what)
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_slu_solver_seti
subroutine c_slu_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='c_slu_solver_setc'
info = psb_success_
call psb_erractionsave(err_act)
call mld_stringval(val,ival,info)
if (info == psb_success_) call sv%set(what,ival,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_slu_solver_setc
subroutine c_slu_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='c_slu_solver_setr'
call psb_erractionsave(err_act)
info = psb_success_
select case(what)
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
!!$ goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_slu_solver_setr
subroutine c_slu_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_slu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='c_slu_solver_free'
call psb_erractionsave(err_act)
info = mld_cslu_free(sv%lufactors)
if (info /= psb_success_) goto 9999
sv%lufactors = c_null_ptr
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_slu_solver_free
subroutine c_slu_solver_descr(sv,info,iout)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_c_slu_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_c_slu_solver_descr'
integer :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' SuperLU Sparse Factorization Solver. '
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine c_slu_solver_descr
function c_slu_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_c_slu_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 2*psb_sizeof_int + psb_sizeof_sp
val = val + sv%symbsize
val = val + sv%numsize
return
end function c_slu_solver_sizeof
end module mld_c_slu_solver
mlprec/mld_caggrmap_bld.f90
+3 -3
View File
@@ -82,7 +82,7 @@
subroutine mld_caggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_caggrmap_bld
use mld_c_inner_mod, mld_protect_name => mld_caggrmap_bld
implicit none
@@ -165,7 +165,7 @@ contains
subroutine mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
use psb_sparse_mod
use mld_inner_mod !, mld_protect_name => mld_daggrmap_bld
use mld_c_inner_mod !, mld_protect_name => mld_daggrmap_bld
implicit none
@@ -251,7 +251,7 @@ contains
call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_sp_getrow')
call psb_errpush(info,name,a_err='csget')
goto 9999
end if
mlprec/mld_caggrmat_asb.f90
+2 -2
View File
@@ -101,7 +101,7 @@
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_caggrmat_asb
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_asb
implicit none
@@ -126,7 +126,7 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_info(ictxt, me, np)
select case (p%iprcparm(mld_aggr_kind_))
select case (p%parms%aggr_kind)
case (mld_no_smooth_)
call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
mlprec/mld_caggrmat_nosmth_asb.F90
+7 -7
View File
@@ -50,7 +50,7 @@
! 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_),
! replicated on each of them, according to the value of p%parms%coarse_mat
! specified by the user through mld_cprecinit and mld_cprecset.
!
! For details see
@@ -83,7 +83,7 @@
!
subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_caggrmat_nosmth_asb
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_nosmth_asb
#ifdef MPI_MOD
use mpi
@@ -93,7 +93,7 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
include 'mpif.h'
#endif
! Arguments
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
@@ -136,7 +136,7 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1=sum(nlaggr(1:me))
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
do i=1, nrow
ilaggr(i) = ilaggr(i) + naggrm1
end do
@@ -148,7 +148,7 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
call acoo1%allocate(ncol,ntaggr,ncol)
else
call acoo1%allocate(ncol,naggr,ncol)
@@ -180,7 +180,7 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call bcoo%fix(info)
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
@@ -217,7 +217,7 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call ac_coo%fix(info)
call p%ac%mv_from(ac_coo)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
else if (p%parms%coarse_mat == mld_distr_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
mlprec/mld_caggrmat_smth_asb.F90
+22 -22
View File
@@ -58,7 +58,7 @@
! 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_omega_alg_), specified by the user
! according to the value of p%parms%aggr_omega_alg, specified by the user
! through mld_cprecinit and mld_cprecset.
!
! This routine can also build A_C according to a "bizarre" aggregation algorithm,
@@ -67,7 +67,7 @@
! 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_),
! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_cprecinit and mld_cprecset.
!
! For more details see
@@ -100,7 +100,7 @@
!
subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_caggrmat_smth_asb
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_smth_asb
#ifdef MPI_MOD
use mpi
@@ -150,7 +150,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
theta = p%rprcparm(mld_aggr_thresh_)
theta = p%parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
@@ -165,11 +165,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(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_)) )
ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.&
& ( (p%parms%aggr_kind == mld_biz_prol_).and.&
& (p%parms%coarse_mat == mld_repl_mat_)) )
filter_mat = (p%iprcparm(mld_aggr_filter_) == mld_filter_mat_)
filter_mat = (p%parms%aggr_filter == mld_filter_mat_)
if (ml_global_nmb) then
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
@@ -283,11 +283,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info /= psb_success_) goto 9999
if (p%iprcparm(mld_aggr_omega_alg_) == mld_eig_est_) then
if (p%parms%aggr_omega_alg == mld_eig_est_) then
if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then
if (p%parms%aggr_eig == mld_max_norm_) then
if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
if (p%parms%aggr_kind == mld_biz_prol_) then
!
! This only works with CSR
@@ -317,7 +317,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
omega = 4.d0/(3.d0*anorm)
p%rprcparm(mld_aggr_omega_val_) = omega
p%parms%aggr_omega_val = omega
else
info = psb_err_internal_error_
@@ -325,11 +325,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
else if (p%iprcparm(mld_aggr_omega_alg_) == mld_user_choice_) then
else if (p%parms%aggr_omega_alg == mld_user_choice_) then
omega = p%rprcparm(mld_aggr_omega_val_)
omega = p%parms%aggr_omega_val
else if (p%iprcparm(mld_aggr_omega_alg_) /= mld_user_choice_) then
else if (p%parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999
@@ -438,9 +438,9 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_numbmm(a,am1,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',p%iprcparm(mld_aggr_kind_), mld_smooth_prol_
& 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
if (p%parms%aggr_kind == mld_smooth_prol_) then
call am2%transp(am1)
call am2%mv_to(acoo2)
nzl = acoo2%get_nzeros()
@@ -472,13 +472,13 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
if (p%parms%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 == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call am4%free()
else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
else if (p%parms%aggr_kind == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info)
endif
if(info /= psb_success_) then
@@ -501,11 +501,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
select case(p%iprcparm(mld_aggr_kind_))
select case(p%parms%aggr_kind)
case(mld_smooth_prol_)
select case(p%iprcparm(mld_coarse_mat_))
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
@@ -593,7 +593,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
case(mld_biz_prol_)
select case(p%iprcparm(mld_coarse_mat_))
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
mlprec/mld_ccoarse_bld.f90
+13 -18
View File
@@ -68,7 +68,7 @@
subroutine mld_ccoarse_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_ccoarse_bld
use mld_c_inner_mod, mld_protect_name => mld_ccoarse_bld
implicit none
@@ -90,30 +90,25 @@ subroutine mld_ccoarse_bld(a,desc_a,p,info)
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',&
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
call mld_check_def(p%iprcparm(mld_aggr_alg_),'Aggregation',&
call mld_check_def(p%parms%aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_aggr_alg)
call mld_check_def(p%iprcparm(mld_aggr_kind_),'Smoother',&
call mld_check_def(p%parms%aggr_kind,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_kind)
call mld_check_def(p%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
call mld_check_def(p%iprcparm(mld_aggr_filter_),'Use filtered matrix',&
call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',&
& mld_no_filter_mat_,is_legal_aggr_filter)
call mld_check_def(p%iprcparm(mld_smoother_pos_),'smooth_pos',&
call mld_check_def(p%parms%smoother_pos,'smooth_pos',&
& mld_pre_smooth_,is_legal_ml_smooth_pos)
call mld_check_def(p%iprcparm(mld_aggr_omega_alg_),'Omega Alg.',&
call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',&
& mld_eig_est_,is_legal_ml_aggr_omega_alg)
call mld_check_def(p%iprcparm(mld_aggr_eig_),'Eigenvalue estimate',&
call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',&
& mld_max_norm_,is_legal_ml_aggr_eig)
call mld_check_def(p%rprcparm(mld_aggr_omega_val_),'Omega',szero,is_legal_s_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
call mld_check_def(p%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega)
call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
!
! Build a mapping between the row indices of the fine-level matrix
@@ -121,7 +116,7 @@ subroutine mld_ccoarse_bld(a,desc_a,p,info)
! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level.
!
call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),&
call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_thresh,&
& a,desc_a,ilaggr,nlaggr,info)
if (info /= psb_success_) then
mlprec/mld_cilu0_fact.f90
+1 -1
View File
@@ -102,7 +102,7 @@
subroutine mld_cilu0_fact(ialg,a,l,u,d,info,blck,upd)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_cilu0_fact
use mld_c_inner_mod!, mld_protect_name => mld_cilu0_fact
implicit none
mlprec/mld_ciluk_fact.f90
+1 -1
View File
@@ -99,7 +99,7 @@
subroutine mld_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_ciluk_fact
use mld_c_inner_mod!, mld_protect_name => mld_ciluk_fact
implicit none
mlprec/mld_cilut_fact.f90
+1 -1
View File
@@ -95,7 +95,7 @@
subroutine mld_cilut_fact(fill_in,thres,a,l,u,d,info,blck)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_cilut_fact
use mld_c_inner_mod!, mld_protect_name => mld_cilut_fact
implicit none
mlprec/mld_cmlprec_aply.f90
+25 -26
View File
@@ -270,11 +270,11 @@
!
!
!
! Hybrid multiplicative, pre- and post-smoothing
! Hybrid multiplicative, pre- and post-smoothing (two-side) variant
!
! For details on the hybrid multiplicative multilevel Schwarz preconditioner
! with pre- and post-smoothing (symmetrized multiplicative multilevel), see
! the Algorithm 3.2.2 of the book:
!
! For details on the symmetrized hybrid multiplicative multilevel Schwarz
! preconditioner, see the Algorithm 3.2.2 of the book:
! B.F. Smith, P.E. Bjorstad & W.D. Gropp,
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
@@ -315,7 +315,7 @@
subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_cmlprec_aply
use mld_c_inner_mod, mld_protect_name => mld_cmlprec_aply
implicit none
@@ -456,13 +456,12 @@ contains
end if
end if
select case(p%precv(level)%iprcparm(mld_ml_type_))
select case(p%precv(level)%parms%ml_type)
case(mld_no_ml_)
!
! No preconditioning, should not really get here
!
write(0,*) 'MLD_NO_ML_ in inner_ml ',level
call psb_errpush(psb_err_internal_error_,name,&
& a_err='mld_no_ml_ in mlprc_aply?')
goto 9999
@@ -486,7 +485,7 @@ contains
end if
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -514,8 +513,7 @@ contains
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
select case(p%precv(level)%iprcparm(mld_smoother_pos_))
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
@@ -555,13 +553,13 @@ contains
& work=work,trans=trans)
if (info /= psb_success_) goto 9999
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -593,9 +591,9 @@ contains
! Apply the base preconditioner
!
if (level < nlev) then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
@@ -653,9 +651,9 @@ contains
! Apply the base preconditioner
!
if (level < nlev) then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
@@ -720,13 +718,13 @@ contains
& work=work,trans=trans)
if (info /= psb_success_) goto 9999
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -763,19 +761,20 @@ contains
goto 9999
end if
end if
call psb_geaxpby(cone,mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%tx,&
call psb_geaxpby(cone,mlprec_wrk(level)%x2l,czero,&
& mlprec_wrk(level)%tx,&
& p%precv(level)%base_desc,info)
!
! Apply the base preconditioner
!
if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
end if
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
@@ -817,9 +816,9 @@ contains
! Apply the base preconditioner
!
if (trans == 'N') then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
end if
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,&
@@ -836,7 +835,7 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%iprcparm(mld_smoother_pos_),0,0,0,0/))
& i_Err=(/p%precv(level)%parms%smoother_pos,0,0,0,0/))
goto 9999
end select
@@ -844,7 +843,7 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%iprcparm(mld_ml_type_),0,0,0,0/))
& i_Err=(/p%precv(level)%parms%ml_type,0,0,0,0/))
goto 9999
end select
mlprec/mld_cmlprec_bld.f90
+79 -161
View File
@@ -67,12 +67,8 @@
subroutine mld_cmlprec_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_cmlprec_bld
use mld_prec_mod
use mld_c_jac_smoother
use mld_c_as_smoother
use mld_c_diag_solver
use mld_c_ilu_solver
use mld_c_inner_mod, mld_protect_name => mld_cmlprec_bld
use mld_c_prec_mod
Implicit None
@@ -89,6 +85,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
integer :: ipv(mld_ifpsz_), val
integer :: int_err(5)
character :: upd_
type(mld_sml_parms) :: prm
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -162,17 +159,10 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%precv(1)%iprcparm(:) = ipv(:)
end if
call psb_bcast(ictxt,p%precv(1)%parms)
!
! Finest level first; remember to fix base_a and base_desc
!
call init_baseprec_av(p%precv(1)%prec,info)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
@@ -187,13 +177,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(i)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(i)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, resetting.'
p%precv(i)%iprcparm(:) = ipv(:)
end if
call psb_bcast(ictxt,p%precv(1)%parms)
!
! Sanity checks on the parameters
@@ -202,12 +186,12 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%precv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
call check_coarse_lev(p%precv(i))
!!$ call check_coarse_lev(p%precv(i))
end if
@@ -218,7 +202,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
! Build the mapping between levels i-1 and i and the matrix
! at level i
!
call init_baseprec_av(p%precv(i)%prec,info)
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
@@ -284,7 +267,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
i = iszv
call check_coarse_lev(p%precv(i))
call init_baseprec_av(p%precv(i)%prec,info)
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then
@@ -301,75 +283,30 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
select case(p%precv(i)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%precv(i)%prec%iprcparm(mld_sub_fillin_),&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%precv(i)%prec%rprcparm(mld_sub_iluthrs_),&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_),&
call mld_check_def(p%precv(i)%parms%sweeps,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_pre_),&
call mld_check_def(p%precv(i)%parms%sweeps_pre,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_post_),&
call mld_check_def(p%precv(i)%parms%sweeps_post,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
if (.not.allocated(p%precv(i)%sm)) then
!! Error: should have called mld_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (.not.allocated(p%precv(i)%sm%sv)) then
!! Error: should have called mld_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
!
! Test version for beginning of OO stuff.
!
if (allocated(p%precv(i)%sm)) then
call p%precv(i)%sm%free(info)
if (info == psb_success_) deallocate(p%precv(i)%sm,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
end if
select case (p%precv(i)%prec%iprcparm(mld_smoother_type_))
case(mld_bjac_, mld_jac_)
allocate(mld_c_jac_smoother_type :: p%precv(i)%sm, stat=info)
case(mld_as_)
allocate(mld_c_as_smoother_type :: p%precv(i)%sm, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Smoother allocation error',info,&
& p%precv(i)%prec%iprcparm(mld_smoother_type_)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(i)%sm%set(mld_sub_restr_,p%precv(i)%prec%iprcparm(mld_sub_restr_),info)
call p%precv(i)%sm%set(mld_sub_prol_,p%precv(i)%prec%iprcparm(mld_sub_prol_),info)
call p%precv(i)%sm%set(mld_sub_ovr_,p%precv(i)%prec%iprcparm(mld_sub_ovr_),info)
select case (p%precv(i)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
allocate(mld_c_ilu_solver_type :: p%precv(i)%sm%sv, stat=info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_solve_,&
& p%precv(i)%prec%iprcparm(mld_sub_solve_),info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_fillin_,&
& p%precv(i)%prec%iprcparm(mld_sub_fillin_),info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_iluthrs_,&
& p%precv(i)%prec%rprcparm(mld_sub_iluthrs_),info)
case(mld_diag_scale_)
allocate(mld_c_diag_solver_type :: p%precv(i)%sm%sv, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Solver allocation error',info,&
& p%precv(i)%prec%iprcparm(mld_sub_solve_)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,'F',info)
if (info /= psb_success_) then
@@ -397,86 +334,67 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
contains
subroutine init_baseprec_av(p,info)
type(mld_cbaseprec_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 /= psb_success_) return
!!$ endif
!!$ end if
!!$ if (.not.(allocated(p%av))) then
!!$ allocate(p%av(mld_max_avsz_),stat=info)
!!$ if (info /= psb_success_) return
!!$ end if
!!$ do k=1,size(p%av)
!!$ call psb_nullify_sp(p%av(k))
!!$ end do
end subroutine init_baseprec_av
subroutine check_coarse_lev(prec)
type(mld_conelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
val = prec%iprcparm(mld_coarse_solve_)
select case (val)
case(mld_jac_)
if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
end if
prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
case(mld_bjac_)
if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
& ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
!!$#if defined(HAVE_UMF_)
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$#elif defined(HAVE_SLU_)
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$#else
prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$#endif
end if
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
case(mld_umf_, mld_slu_)
if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
prec%prec%iprcparm(mld_sub_solve_) = val
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
end if
case(mld_sludist_)
if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
prec%prec%iprcparm(mld_sub_solve_) = val
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
prec%prec%iprcparm(mld_smoother_sweeps_) = 1
end if
end select
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_cmlprec_bld
mlprec/mld_cprecaply.f90
+4 -4
View File
@@ -74,7 +74,7 @@
subroutine mld_cprecaply(prec,x,y,desc_data,info,trans,work)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_cprecaply
use mld_c_inner_mod, mld_protect_name => mld_cprecaply
implicit none
@@ -120,7 +120,7 @@ subroutine mld_cprecaply(prec,x,y,desc_data,info,trans,work)
end if
if (.not.(allocated(prec%precv))) then
!! Error 1: should call mld_dprecbld
!! Error 1: should call mld_cprecbld
info=3112
call psb_errpush(info,name)
goto 9999
@@ -140,7 +140,7 @@ subroutine mld_cprecaply(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,&
& prec%precv(1)%iprcparm(mld_smoother_sweeps_), work_,info)
& prec%precv(1)%parms%sweeps, work_,info)
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
@@ -207,7 +207,7 @@ end subroutine mld_cprecaply
subroutine mld_cprecaply1(prec,x,desc_data,info,trans)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_cprecaply1
use mld_c_inner_mod, mld_protect_name => mld_cprecaply1
implicit none
mlprec/mld_cprecbld.f90
+21 -107
View File
@@ -61,12 +61,8 @@
subroutine mld_cprecbld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod
use mld_prec_mod, mld_protect_name => mld_cprecbld
use mld_c_jac_smoother
use mld_c_as_smoother
use mld_c_diag_solver
use mld_c_ilu_solver
use mld_c_inner_mod
use mld_c_prec_mod, mld_protect_name => mld_cprecbld
Implicit None
@@ -84,6 +80,7 @@ subroutine mld_cprecbld(a,desc_a,p,info)
integer :: ipv(mld_ifpsz_), val
integer :: int_err(5)
character :: upd_
type(mld_sml_parms) :: prm
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -156,17 +153,8 @@ subroutine mld_cprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%precv(1)%iprcparm(:) = ipv(:)
end if
!
! Remember to fix base_a and base_desc
!
call init_baseprec_av(p%precv(1)%prec,info)
call psb_bcast(ictxt,p%precv(1)%parms)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
@@ -174,81 +162,26 @@ subroutine mld_cprecbld(a,desc_a,p,info)
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Build the base preconditioner
!
select case(p%precv(1)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%precv(1)%prec%iprcparm(mld_sub_fillin_),&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%precv(1)%prec%rprcparm(mld_sub_iluthrs_),&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
call mld_check_def(p%precv(1)%iprcparm(mld_smoother_sweeps_),&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
!
! Test version for beginning of OO stuff.
!
if (allocated(p%precv(1)%sm)) then
call p%precv(1)%sm%free(info)
if (info == psb_success_) deallocate(p%precv(1)%sm,stat=info)
call p%precv(1)%check(info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name,a_err='One level preconditioner build.')
write(0,*) ' Smoother check error',info
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner check.')
goto 9999
endif
end if
select case (p%precv(1)%prec%iprcparm(mld_smoother_type_))
case(mld_jac_, mld_bjac_)
allocate(mld_c_jac_smoother_type :: p%precv(1)%sm, stat=info)
case(mld_as_)
allocate(mld_c_as_smoother_type :: p%precv(1)%sm, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Smoother allocation error',info,&
& p%precv(1)%prec%iprcparm(mld_smoother_type_)
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(1)%sm%set(mld_sub_restr_,p%precv(1)%prec%iprcparm(mld_sub_restr_),info)
call p%precv(1)%sm%set(mld_sub_prol_,p%precv(1)%prec%iprcparm(mld_sub_prol_),info)
call p%precv(1)%sm%set(mld_sub_ovr_,p%precv(1)%prec%iprcparm(mld_sub_ovr_),info)
select case (p%precv(1)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
allocate(mld_c_ilu_solver_type :: p%precv(1)%sm%sv, stat=info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_solve_,&
& p%precv(1)%prec%iprcparm(mld_sub_solve_),info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_fillin_,&
& p%precv(1)%prec%iprcparm(mld_sub_fillin_),info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_iluthrs_,&
& p%precv(1)%prec%rprcparm(mld_sub_iluthrs_),info)
case(mld_diag_scale_)
allocate(mld_c_diag_solver_type :: p%precv(1)%sm%sv, stat=info)
case default
info = -1
end select
call p%precv(1)%sm%build(a,desc_a,upd_,info)
if (info /= psb_success_) then
write(0,*) ' Smoother build error',info
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
if (info /= psb_success_) then
write(0,*) ' Solver allocation error',info,&
& p%precv(1)%prec%iprcparm(mld_sub_solve_)
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(1)%sm%build(a,desc_a,upd_,info)
if (info /= psb_success_) then
write(0,*) ' Smoother build error',info
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
!
! Number of levels > 1
!
!
! Number of levels > 1
!
else if (iszv > 1) then
!
! Build the multilevel preconditioner
@@ -256,7 +189,8 @@ subroutine mld_cprecbld(a,desc_a,p,info)
call mld_mlprec_bld(a,desc_a,p,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Multilevel preconditioner build.')
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Multilevel preconditioner build.')
goto 9999
endif
end if
@@ -272,25 +206,5 @@ subroutine mld_cprecbld(a,desc_a,p,info)
end if
return
contains
subroutine init_baseprec_av(p,info)
type(mld_cbaseprec_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 /= psb_success_) return
!!$ endif
!!$ end if
!!$ if (.not.(allocated(p%av))) then
!!$ allocate(p%av(mld_max_avsz_),stat=info)
!!$ if (info /= psb_success_) return
!!$ end if
!!$ do k=1,size(p%av)
!!$ call psb_nullify_sp(p%av(k))
!!$ end do
end subroutine init_baseprec_av
end subroutine mld_cprecbld
mlprec/mld_cprecinit.F90
+41 -167
View File
@@ -91,11 +91,15 @@
subroutine mld_cprecinit(p,ptype,info,nlev)
use psb_sparse_mod
use mld_prec_mod, mld_protect_name => mld_cprecinit
use mld_c_prec_mod, mld_protect_name => mld_cprecinit
use mld_c_jac_smoother
use mld_c_as_smoother
use mld_c_id_solver
use mld_c_diag_solver
use mld_c_ilu_solver
#if defined(HAVE_SLU_)
use mld_c_slu_solver
#endif
implicit none
@@ -119,104 +123,41 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
endif
select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC')
case ('NOPREC','NONE')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_c_base_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_noprec_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_c_id_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('JAC','DIAG','JACOBI')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_c_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_c_diag_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('BJAC')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_c_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_c_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('AS')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_c_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_c_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('ML')
@@ -228,103 +169,36 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
end if
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_c_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
if (nlev_ == 1) return
allocate(mld_c_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_c_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
allocate(mld_c_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
end do
ilev_ = nlev_
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_c_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_coarse_solve_) = mld_bjac_
#if defined(HAVE_SLU_)
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_slu_
#if defined(HAVE_SLU_)
allocate(mld_c_slu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
#else
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
allocate(mld_c_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
#endif
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 4
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 4
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 4
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
call p%precv(ilev_)%default()
call p%precv(ilev_)%set(mld_smoother_sweeps_,4,info)
call p%precv(ilev_)%set(mld_sub_restr_,psb_none_,info)
call p%precv(ilev_)%set(mld_sub_prol_,psb_none_,info)
call p%precv(ilev_)%set(mld_sub_ovr_,0,info)
!!$ write(0,*) 'Check 5: ',allocated(p%precv(1)%sm)
case default
write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"'
mlprec/mld_cprecset.F90
+459 -145
View File
@@ -79,7 +79,15 @@
subroutine mld_cprecseti(p,what,val,info,ilev)
use psb_sparse_mod
use mld_prec_mod, mld_protect_name => mld_cprecseti
use mld_c_prec_mod, mld_protect_name => mld_cprecseti
use mld_c_jac_smoother
use mld_c_as_smoother
use mld_c_id_solver
use mld_c_diag_solver
use mld_c_ilu_solver
#ifdef HAVE_SLU_
use mld_c_slu_solver
#endif
implicit none
@@ -98,7 +106,8 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
if (.not.allocated(p%precv)) then
info = 3111
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
write(psb_err_unit,*) name,': Error: uninitialized preconditioner,',&
&' should call MLD_PRECINIT'
return
endif
nlev_ = size(p%precv)
@@ -111,21 +120,9 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
if ((ilev_<1).or.(ilev_ > nlev_)) then
info = -1
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
write(psb_err_unit,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
return
endif
if (.not.allocated(p%precv(ilev_)%prec%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
return
endif
!
! Set preconditioner parameters at level ilev.
@@ -137,37 +134,44 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
! Rules for fine level are slightly different.
!
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,mld_smoother_sweeps_)
p%precv(ilev_)%prec%iprcparm(what) = val
case(mld_smoother_type_)
call onelev_set_smoother(p%precv(ilev_),val,info)
case(mld_sub_solve_)
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
call p%precv(ilev_)%set(what,val,info)
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
end select
else if (ilev_ > 1) then
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
case(mld_smoother_type_)
call onelev_set_smoother(p%precv(ilev_),val,info)
case(mld_sub_solve_)
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_)
p%precv(ilev_)%prec%iprcparm(what) = val
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
p%precv(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%precv(ilev_)%iprcparm(mld_coarse_mat_) = val
& mld_coarse_mat_)
call p%precv(ilev_)%set(what,val,info)
case(mld_coarse_subsolve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%precv(ilev_)%iprcparm(mld_sub_solve_) = val
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_coarse_solve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
@@ -176,16 +180,30 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
end if
if (nlev_ > 1) then
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
select case (val)
case(mld_umf_, mld_slu_)
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),val,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
case(mld_sludist_)
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
end select
endif
case(mld_coarse_sweeps_)
if (ilev_ /= nlev_) then
@@ -193,14 +211,15 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
info = -2
return
end if
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = val
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
case(mld_coarse_fillin_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = val
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@@ -214,82 +233,92 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
! levels
!
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_)
case(mld_sub_solve_)
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%sm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
& ': Error: uninitialized preconditioner component,',&
& ' should call MLD_PRECINIT'
info = -1
return
endif
p%precv(ilev_)%prec%iprcparm(what) = val
call onelev_set_solver(p%precv(ilev_),val,info)
end do
case(mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_smoother_sweeps_)
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_smoother_type_)
do ilev_=1,max(1,nlev_-1)
call onelev_set_smoother(p%precv(ilev_),val,info)
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
do ilev_=2,nlev_
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%precv(ilev_)%iprcparm(what) = val
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,&
& mld_aggr_eig_,mld_aggr_filter_)
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_coarse_mat_)
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
& ': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%precv(nlev_)%iprcparm(mld_coarse_mat_) = val
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_mat_,val,info)
end if
case(mld_coarse_solve_)
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
end select
endif
if (nlev_ > 1) then
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_subsolve_)
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
end if
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
if (nlev_ > 1) then
call onelev_set_solver(p%precv(nlev_),val,info)
endif
case(mld_coarse_sweeps_)
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
end if
case(mld_coarse_fillin_)
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_fillin_) = val
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
end if
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@@ -297,8 +326,320 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
endif
contains
subroutine onelev_set_smoother(level,val,info)
type(mld_conelev_type), intent(inout) :: level
integer, intent(in) :: val
integer, intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_noprec_)
if (allocated(level%sm)) then
select type (sm => level%sm)
type is (mld_c_base_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_base_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_base_smoother_type ::&
& level%sm, stat=info)
if (info ==0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_jac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_jac_smoother_type :: &
& level%sm, stat=info)
if (info == 0) allocate(mld_c_diag_solver_type :: &
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_diag_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_bjac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_jac_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_as_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_as_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_as_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_as_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(level%sm)) &
& call level%sm%default()
end subroutine onelev_set_smoother
subroutine onelev_set_solver(level,val,info)
type(mld_conelev_type), intent(inout) :: level
integer, intent(in) :: val
integer, intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_f_none_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_id_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_id_solver_type :: level%sm%sv, stat=info)
endif
case (mld_diag_scale_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_diag_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_diag_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_diag_solver_type :: level%sm%sv, stat=info)
endif
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_ilu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_ilu_solver_type :: level%sm%sv, stat=info)
endif
#ifdef HAVE_SLU_
case (mld_slu_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_slu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_slu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_slu_solver_type :: level%sm%sv, stat=info)
endif
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
end subroutine onelev_set_solver
end subroutine mld_cprecseti
subroutine mld_cprecsetsm(p,val,info,ilev)
use psb_sparse_mod
use mld_c_prec_mod, mld_protect_name => mld_cprecsetsm
implicit none
! Arguments
type(mld_cprec_type), intent(inout) :: p
class(mld_c_base_smoother_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
! Local variables
integer :: ilev_, nlev_, ilmin, ilmax
character(len=*), parameter :: name='mld_precseti'
info = psb_success_
if (.not.allocated(p%precv)) then
info = 3111
write(0,*) name,': Error: uninitialized preconditioner,',&
&' should call MLD_PRECINIT'
return
endif
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
ilmin = ilev
ilmax = ilev
else
ilev_ = 1
ilmin = 1
ilmax = nlev_
end if
if ((ilev_<1).or.(ilev_ > nlev_)) then
info = -1
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
do ilev_ = ilmin, ilmax
if (allocated(p%precv(ilev_)%sm)) then
if (allocated(p%precv(ilev_)%sm%sv)) then
deallocate(p%precv(ilev_)%sm%sv)
endif
deallocate(p%precv(ilev_)%sm)
end if
#ifdef HAVE_MOLD
allocate(p%precv(ilev_)%sm,mold=val)
#else
allocate(p%precv(ilev_)%sm,source=val)
#endif
call p%precv(ilev_)%sm%default()
end do
end subroutine mld_cprecsetsm
subroutine mld_cprecsetsv(p,val,info,ilev)
use psb_sparse_mod
use mld_c_prec_mod, mld_protect_name => mld_cprecsetsv
implicit none
! Arguments
type(mld_cprec_type), intent(inout) :: p
class(mld_c_base_solver_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
! Local variables
integer :: ilev_, nlev_, ilmin, ilmax
character(len=*), parameter :: name='mld_precseti'
info = psb_success_
if (.not.allocated(p%precv)) then
info = 3111
write(0,*) name,': Error: uninitialized preconditioner,',&
&' should call MLD_PRECINIT'
return
endif
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
ilmin = ilev
ilmax = ilev
else
ilev_ = 1
ilmin = 1
ilmax = nlev_
end if
if ((ilev_<1).or.(ilev_ > nlev_)) then
info = -1
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
do ilev_ = ilmin, ilmax
if (allocated(p%precv(ilev_)%sm)) then
if (allocated(p%precv(ilev_)%sm%sv)) &
& deallocate(p%precv(ilev_)%sm%sv)
#ifdef HAVE_MOLD
allocate(p%precv(ilev_)%sm%sv,mold=val)
#else
allocate(p%precv(ilev_)%sm%sv,source=val)
#endif
call p%precv(ilev_)%sm%sv%default()
else
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component,',&
&' should call MLD_PRECINIT/MLD_PRECSET'
return
end if
end do
end subroutine mld_cprecsetsv
!
! Subroutine: mld_cprecsetc
! Version: complex
@@ -342,7 +683,7 @@ end subroutine mld_cprecseti
subroutine mld_cprecsetc(p,what,string,info,ilev)
use psb_sparse_mod
use mld_prec_mod, mld_protect_name => mld_cprecsetc
use mld_c_prec_mod, mld_protect_name => mld_cprecsetc
implicit none
@@ -353,7 +694,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev)
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
! Local variables
! Local variables
integer :: ilev_, nlev_,val
character(len=*), parameter :: name='mld_precsetc'
@@ -376,16 +717,9 @@ subroutine mld_cprecsetc(p,what,string,info,ilev)
info = -1
return
endif
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
endif
call mld_stringval(string,val,info)
if (info == psb_success_) call mld_inner_precset(p,what,val,info,ilev=ilev)
end subroutine mld_cprecsetc
@@ -433,7 +767,7 @@ end subroutine mld_cprecsetc
subroutine mld_cprecsetr(p,what,val,info,ilev)
use psb_sparse_mod
use mld_prec_mod, mld_protect_name => mld_cprecsetr
use mld_c_prec_mod, mld_protect_name => mld_cprecsetr
implicit none
@@ -457,22 +791,19 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
end if
if (.not.allocated(p%precv)) then
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
write(0,*) name,': Error: uninitialized preconditioner,',&
&' should call MLD_PRECINIT'
info = 3111
return
endif
nlev_ = size(p%precv)
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
write(0,*) name,': Error: invalid ILEV/NLEV combination',&
& ilev_, nlev_
info = -1
return
endif
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
endif
!
! Set preconditioner parameters at level ilev.
@@ -485,7 +816,8 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
!
select case(what)
case(mld_sub_iluthrs_)
p%precv(ilev_)%prec%rprcparm(what) = val
call p%precv(ilev_)%set(what,val,info)
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@@ -494,9 +826,9 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then
select case(what)
case(mld_sub_iluthrs_)
p%precv(ilev_)%prec%rprcparm(what) = val
call p%precv(ilev_)%set(what,val,info)
case(mld_aggr_omega_val_,mld_aggr_thresh_)
p%precv(ilev_)%rprcparm(what) = val
call p%precv(ilev_)%set(what,val,info)
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@@ -511,38 +843,20 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
select case(what)
case(mld_sub_iluthrs_)
do ilev_=1,nlev_
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%precv(ilev_)%prec%rprcparm(what) = val
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_coarse_iluthrs_)
ilev_=nlev_
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%precv(ilev_)%prec%rprcparm(mld_sub_iluthrs_) = val
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info)
case(mld_aggr_omega_val_)
do ilev_=2,nlev_
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%precv(ilev_)%rprcparm(what) = val
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%precv(ilev_)%rprcparm(what) = val
call p%precv(ilev_)%set(what,val,info)
end do
case default
write(0,*) name,': Error: invalid WHAT'
mlprec/mld_cslu_bld.f90
+1 -1
View File
@@ -72,7 +72,7 @@
subroutine mld_cslu_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_cslu_bld
use mld_c_inner_mod, mld_protect_name => mld_cslu_bld
implicit none
mlprec/mld_cslu_interface.c
+54 -117
View File
@@ -115,51 +115,15 @@ typedef struct {
#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,
int
mld_cslu_fact(int n, int nnz,
#ifdef HAVE_SLU_
complex *values,
#else
void *values,
#endif
int *info)
int *rowptr, int *colind, void **f_factors)
{
/*
@@ -173,7 +137,7 @@ mld_cslu_fact_(int *n, int *nnz,
*/
#ifdef Have_SLU_
SuperMatrix A, AC, B;
SuperMatrix A, AC;
SuperMatrix *L, *U;
int *perm_r; /* row permutations from partial pivoting */
int *perm_c; /* column permutation vector */
@@ -187,6 +151,7 @@ mld_cslu_fact_(int *n, int *nnz,
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
int info;
trans = NOTRANS;
@@ -197,17 +162,13 @@ mld_cslu_fact_(int *n, int *nnz,
/* 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,
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[].");
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:
@@ -226,9 +187,9 @@ mld_cslu_fact_(int *n, int *nnz,
relax = sp_ienv(2);
cgstrf(&options, &AC, drop_tol, relax, panel_size,
etree, NULL, 0, perm_c, perm_r, L, U, &stat, info);
etree, NULL, 0, perm_c, perm_r, L, U, &stat, &info);
if ( *info == 0 ) {
if ( info == 0 ) {
Lstore = (SCformat *) L->Store;
Ustore = (NCformat *) U->Store;
cQuerySpace(L, U, &mem_usage);
@@ -241,8 +202,8 @@ mld_cslu_fact_(int *n, int *nnz,
mem_usage.expansions);
#endif
} else {
printf("cgstrf() error returns INFO= %d\n", *info);
if ( *info <= *n ) { /* factorization completes */
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,
@@ -250,48 +211,43 @@ mld_cslu_fact_(int *n, int *nnz,
}
}
/* 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;
*f_factors = (void *) LUfactors;
/* Free un-wanted storage */
SUPERLU_FREE(etree);
Destroy_SuperMatrix_Store(&A);
Destroy_CompCol_Permuted(&AC);
StatFree(&stat);
return(info);
#else
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
*info=-1;
return(-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,
int
mld_cslu_solve(int itrans, int n, int nrhs,
#ifdef HAVE_SLU_
complex *b,
#else
void *b,
#endif
int *info)
int ldb,void *f_factors)
{
/*
* This routine can be called from Fortran.
* performs triangular solve
*
*/
/*
* This routine can be called from Fortran.
* performs triangular solve
*
*/
int info;
#ifdef Have_SLU_
SuperMatrix B;
SuperMatrix *L, *U;
@@ -308,11 +264,11 @@ mld_cslu_solve_(int *itrans, int *n, int *nrhs,
SuperLUStat_t stat;
factors_t *LUfactors;
if (*itrans == 0) {
if (itrans == 0) {
trans = NOTRANS;
} else if (*itrans ==1) {
} else if (itrans ==1) {
trans = TRANS;
} else if (*itrans ==2) {
} else if (itrans ==2) {
trans = CONJ;
} else {
trans = NOTRANS;
@@ -321,15 +277,15 @@ mld_cslu_solve_(int *itrans, int *n, int *nrhs,
StatInit(&stat);
/* Extract the LU factors in the factors handle */
LUfactors = (factors_t*) *f_factors;
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);
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);
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");
@@ -339,22 +295,15 @@ mld_cslu_solve_(int *itrans, int *n, int *nrhs,
Destroy_SuperMatrix_Store(&B);
StatFree(&stat);
#else
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
*info=-1;
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
info=-1;
#endif
return(info);
}
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)
int
mld_cslu_free(void *f_factors)
{
/*
@@ -364,24 +313,11 @@ mld_cslu_free_(
*
*/
#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;
factors_t *LUfactors;
/* Free the LU factors in the factors handle */
LUfactors = (factors_t*) f_factors;
if (LUfactors != NULL) {
SUPERLU_FREE (LUfactors->perm_r);
SUPERLU_FREE (LUfactors->perm_c);
Destroy_SuperNode_Matrix(LUfactors->L);
@@ -389,10 +325,11 @@ mld_cslu_free_(
SUPERLU_FREE (LUfactors->L);
SUPERLU_FREE (LUfactors->U);
SUPERLU_FREE (LUfactors);
*info = 0;
}
return(0);
#else
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
*info=-1;
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
return(-1);
#endif
}
mlprec/mld_cslud_bld.f90
+1 -1
View File
@@ -69,7 +69,7 @@
subroutine mld_csludist_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_csludist_bld
use mld_c_inner_mod, mld_protect_name => mld_csludist_bld
implicit none
mlprec/mld_csp_renum.f90
+1 -1
View File
@@ -84,7 +84,7 @@
subroutine mld_csp_renum(a,blck,p,atmp,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_csp_renum
use mld_c_inner_mod, mld_protect_name => mld_csp_renum
implicit none
mlprec/mld_cumf_bld.f90
+1 -1
View File
@@ -78,7 +78,7 @@
subroutine mld_cumf_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_cumf_bld
use mld_c_inner_mod, mld_protect_name => mld_cumf_bld
implicit none
mlprec/mld_d_as_smoother.f90
+43 -39
View File
@@ -94,15 +94,15 @@ contains
class(mld_d_as_smoother_type), intent(inout) :: sm
!!$ sm%restr = psb_halo_
!!$ sm%prol = psb_none_
!!$ sm%novr = 1
!!$
!!$
!!$ if (allocated(sm%sv)) then
!!$ call sm%sv%default()
!!$ end if
!!$
sm%restr = psb_halo_
sm%prol = psb_none_
sm%novr = 1
if (allocated(sm%sv)) then
call sm%sv%default()
end if
return
end subroutine d_as_smoother_default
@@ -120,23 +120,23 @@ contains
call psb_erractionsave(err_act)
info = psb_success_
!!$
!!$ call mld_check_def(sm%restr,&
!!$ & 'Restrictor',psb_halo_,is_legal_restrict)
!!$ call mld_check_def(sm%prol,&
!!$ & 'Prolongator',psb_none_,is_legal_prolong)
!!$ call mld_check_def(sm%novr,&
!!$ & 'Overlap layers ',0,is_legal_n_ovr)
!!$
!!$
!!$ if (allocated(sm%sv)) then
!!$ call sm%sv%check(info)
!!$ else
!!$ info=3111
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
call mld_check_def(sm%restr,&
& 'Restrictor',psb_halo_,is_legal_restrict)
call mld_check_def(sm%prol,&
& 'Prolongator',psb_none_,is_legal_prolong)
call mld_check_def(sm%novr,&
& 'Overlap layers ',0,is_legal_n_ovr)
if (allocated(sm%sv)) then
call sm%sv%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@@ -324,14 +324,13 @@ contains
goto 9999
end select
!!$ write(0,*) me,' Entry to inner slver in AS ',tx
call sm%sv%apply(done,tx,dzero,ty,sm%desc_data,trans_,aux,info)
!!$ write(0,*) me,' out from inner slver in AS ',ty
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
&a_err='Error in sub_aply Jacobi Sweeps = 1')
& a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
@@ -478,7 +477,6 @@ contains
! and Y(j) is the approximate solution at sweep j.
!
ww(1:n_row) = tx(1:n_row)
!!$ write(0,*) me,' Entry to spmm in AS-ND',ty
call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
@@ -759,9 +757,6 @@ contains
case default
if (allocated(sm%sv)) then
call sm%sv%set(what,val,info)
!!$ else
!!$ write(0,*) trim(name),' Missing component, not setting!'
!!$ info = 1121
end if
end select
@@ -892,7 +887,7 @@ contains
return
end subroutine d_as_smoother_free
subroutine d_as_smoother_descr(sm,info,iout)
subroutine d_as_smoother_descr(sm,info,iout,coarse)
use psb_sparse_mod
@@ -902,28 +897,37 @@ contains
class(mld_d_as_smoother_type), intent(in) :: sm
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_d_as_smoother_descr'
integer :: iout_
logical :: coarse_
call psb_erractionsave(err_act)
info = psb_success_
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' Additive Schwarz with ',&
& sm%novr, ' overlap layers.'
write(iout_,*) ' Restrictor: ',restrict_names(sm%restr)
write(iout_,*) ' Prolongator: ',prolong_names(sm%prol)
write(iout_,*) ' Local solver:'
if (.not.coarse_) then
write(iout_,*) ' Additive Schwarz with ',&
& sm%novr, ' overlap layers.'
write(iout_,*) ' Restrictor: ',restrict_names(sm%restr)
write(iout_,*) ' Prolongator: ',prolong_names(sm%prol)
write(iout_,*) ' Local solver:'
endif
if (allocated(sm%sv)) then
call sm%sv%descr(info,iout_)
call sm%sv%descr(info,iout_,coarse=coarse)
end if
call psb_erractionrestore(err_act)
mlprec/mld_d_id_solver.f90
+281
View File
@@ -0,0 +1,281 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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.
!!$
!!$
!
!
!
! Identity solver. Reference for nullprec.
!
!
module mld_d_id_solver
use mld_d_prec_type
type, extends(mld_d_base_solver_type) :: mld_d_id_solver_type
contains
procedure, pass(sv) :: build => d_id_solver_bld
procedure, pass(sv) :: apply => d_id_solver_apply
procedure, pass(sv) :: free => d_id_solver_free
procedure, pass(sv) :: seti => d_id_solver_seti
procedure, pass(sv) :: setc => d_id_solver_setc
procedure, pass(sv) :: setr => d_id_solver_setr
procedure, pass(sv) :: descr => d_id_solver_descr
procedure, pass(sv) :: sizeof => d_id_solver_sizeof
end type mld_d_id_solver_type
private :: d_id_solver_bld, d_id_solver_apply, &
& d_id_solver_free, d_id_solver_seti, &
& d_id_solver_setc, d_id_solver_setr,&
& d_id_solver_descr, d_id_solver_sizeof
contains
subroutine d_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_d_id_solver_type), intent(in) :: sv
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer :: n_row,n_col
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_id_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_id_solver_apply
subroutine d_id_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_d_id_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target, optional :: b
! Local variables
integer :: n_row,n_col, nrow_a, nztota
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_id_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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),' start'
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 == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_id_solver_bld
subroutine d_id_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_id_solver_seti'
info = psb_success_
return
end subroutine d_id_solver_seti
subroutine d_id_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_id_solver_setc'
info = psb_success_
return
end subroutine d_id_solver_setc
subroutine d_id_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_id_solver_setr'
info = psb_success_
return
end subroutine d_id_solver_setr
subroutine d_id_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_id_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_id_solver_free'
info = psb_success_
return
end subroutine d_id_solver_free
subroutine d_id_solver_descr(sv,info,iout,coarse)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_id_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_d_id_solver_descr'
integer :: iout_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' Identity local solver '
return
end subroutine d_id_solver_descr
function d_id_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_d_id_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 0
return
end function d_id_solver_sizeof
end module mld_d_id_solver
mlprec/mld_d_ilu_solver.f90
+71 -5
View File
@@ -62,6 +62,7 @@ module mld_d_ilu_solver
procedure, pass(sv) :: setr => d_ilu_solver_setr
procedure, pass(sv) :: descr => d_ilu_solver_descr
procedure, pass(sv) :: sizeof => d_ilu_solver_sizeof
procedure, pass(sv) :: default => d_ilu_solver_default
end type mld_d_ilu_solver_type
@@ -69,7 +70,7 @@ module mld_d_ilu_solver
& d_ilu_solver_free, d_ilu_solver_seti, &
& d_ilu_solver_setc, d_ilu_solver_setr,&
& d_ilu_solver_descr, d_ilu_solver_sizeof, &
& d_ilu_solver_dmp
& d_ilu_solver_default, d_ilu_solver_dmp
interface mld_ilu0_fact
@@ -111,13 +112,74 @@ module mld_d_ilu_solver
end interface
character(len=15), parameter, private :: &
& fact_names(0:4)=(/'none ','DIAG ?? ',&
& fact_names(0:mld_slv_delta_+4)=(/&
& 'none ','none ',&
& 'none ','none ',&
& 'none ','DIAG ?? ',&
& 'ILU(n) ',&
& 'MILU(n) ','ILU(t,n) '/)
contains
subroutine d_ilu_solver_default(sv)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_ilu_solver_type), intent(inout) :: sv
sv%fact_type = mld_ilu_n_
sv%fill_in = 0
sv%thresh = dzero
return
end subroutine d_ilu_solver_default
subroutine d_ilu_solver_check(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_ilu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(sv%fact_type,&
& 'Factorization',mld_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(sv%fill_in,&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(sv%thresh,&
& 'Eps',dzero,is_legal_fact_thrs)
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_ilu_solver_check
subroutine d_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
@@ -347,7 +409,9 @@ contains
case default
! If we end up here, something was wrong up in the call chain.
call psb_errpush(psb_err_alloc_dealloc_,name)
info = psb_err_input_value_invalid_i_
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/3,sv%fact_type,0,0,0/))
goto 9999
end select
@@ -355,7 +419,8 @@ contains
! Here we should add checks for reuse of L and U.
! For the time being just throw an error.
info = 31
call psb_errpush(info, name, i_err=(/3,0,0,0,0/),a_err=upd)
call psb_errpush(info, name,&
& i_err=(/3,0,0,0,0/),a_err=upd)
goto 9999
!
@@ -544,7 +609,7 @@ contains
return
end subroutine d_ilu_solver_free
subroutine d_ilu_solver_descr(sv,info,iout)
subroutine d_ilu_solver_descr(sv,info,iout,coarse)
use psb_sparse_mod
@@ -554,6 +619,7 @@ contains
class(mld_d_ilu_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
mlprec/mld_d_inner_mod.f90
+153
View File
@@ -0,0 +1,153 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_inner_mod.f90
!
! Module: mld_inner_mod
!
! This module defines the interfaces to the real/complex, single/double
! precision versions of the MLD2P4 routines, except those of the user level,
! whose interfaces are defined in mld_prec_mod.f90.
!
module mld_d_inner_mod
use mld_d_prec_type
use mld_d_move_alloc_mod
interface mld_mlprec_bld
subroutine mld_dmlprec_bld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
implicit none
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dprec_type), intent(inout), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_dmlprec_bld
end interface mld_mlprec_bld
interface mld_mlprec_aply
subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_dprec_type), intent(in) :: p
real(psb_dpk_),intent(in) :: alpha,beta
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
character,intent(in) :: trans
real(psb_dpk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_dmlprec_aply
end interface mld_mlprec_aply
interface mld_coarse_bld
subroutine mld_dcoarse_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_dcoarse_bld
end interface mld_coarse_bld
interface mld_aggrmap_bld
subroutine mld_daggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
integer, intent(in) :: aggr_type
real(psb_dpk_), intent(in) :: theta
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
end subroutine mld_daggrmap_bld
end interface mld_aggrmap_bld
interface mld_aggrmat_asb
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_asb
end interface mld_aggrmat_asb
interface mld_aggrmat_nosmth_asb
subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_nosmth_asb
end interface mld_aggrmat_nosmth_asb
interface mld_aggrmat_smth_asb
subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_smth_asb
end interface mld_aggrmat_smth_asb
interface mld_aggrmat_minnrg_asb
subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_minnrg_asb
end interface mld_aggrmat_minnrg_asb
end module mld_d_inner_mod
mlprec/mld_d_move_alloc_mod.f90
+102
View File
@@ -0,0 +1,102 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_move_alloc_mod.f90
!
! Module: mld_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_d_move_alloc_mod
use mld_d_prec_type
interface mld_move_alloc
module procedure mld_donelev_prec_move_alloc,&
& mld_dprec_move_alloc
end interface
contains
subroutine mld_donelev_prec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_donelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call mld_precfree(b,info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_donelev_prec_move_alloc
subroutine mld_dprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_dprec_type), intent(inout) :: a
type(mld_dprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i,isz
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, isz
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_dprec_move_alloc
end module mld_d_move_alloc_mod
mlprec/mld_d_prec_mod.f90
+181
View File
@@ -0,0 +1,181 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_prec_mod.f90
!
! Module: mld_prec_mod
!
! This module defines the interfaces to the real/complex, single/double
! precision versions of the user-level MLD2P4 routines.
!
module mld_d_prec_mod
use mld_d_prec_type
use mld_d_move_alloc_mod
interface mld_precinit
subroutine mld_dprecinit(p,ptype,info,nlev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
character(len=*), intent(in) :: ptype
integer, intent(out) :: info
integer, optional, intent(in) :: nlev
end subroutine mld_dprecinit
end interface
interface mld_precset
module procedure mld_i_dprecsetsm, mld_i_dprecsetsv, &
& mld_i_dprecseti, mld_i_dprecsetc, mld_i_dprecsetr
end interface
interface mld_inner_precset
subroutine mld_dprecsetsm(p,val,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type, mld_d_base_smoother_type
type(mld_dprec_type), intent(inout) :: p
class(mld_d_base_smoother_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_dprecsetsm
subroutine mld_dprecsetsv(p,val,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type, mld_d_base_solver_type
type(mld_dprec_type), intent(inout) :: p
class(mld_d_base_solver_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_dprecsetsv
subroutine mld_dprecseti(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_dprecseti
subroutine mld_dprecsetr(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_dprecsetr
subroutine mld_dprecsetc(p,what,string,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
type(mld_dprec_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_dprecsetc
end interface
interface mld_precbld
subroutine mld_dprecbld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
implicit none
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dprec_type), intent(inout), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_dprecbld
end interface
contains
subroutine mld_i_dprecsetsm(p,val,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type, mld_d_base_smoother_type
type(mld_dprec_type), intent(inout) :: p
class(mld_d_base_smoother_type), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,val,info)
end subroutine mld_i_dprecsetsm
subroutine mld_i_dprecsetsv(p,val,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type, mld_d_base_solver_type
type(mld_dprec_type), intent(inout) :: p
class(mld_d_base_solver_type), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,val,info)
end subroutine mld_i_dprecsetsv
subroutine mld_i_dprecseti(p,what,val,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_dprecseti
subroutine mld_i_dprecsetr(p,what,val,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_dprecsetr
subroutine mld_i_dprecsetc(p,what,val,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_dprecsetc
end module mld_d_prec_mod
mlprec/mld_d_prec_type.f90
+339 -275
View File
@@ -177,6 +177,7 @@ module mld_d_prec_type
type mld_d_base_solver_type
contains
procedure, pass(sv) :: check => d_base_solver_check
procedure, pass(sv) :: dump => d_base_solver_dmp
procedure, pass(sv) :: build => d_base_solver_bld
procedure, pass(sv) :: apply => d_base_solver_apply
@@ -186,13 +187,14 @@ module mld_d_prec_type
procedure, pass(sv) :: setr => d_base_solver_setr
generic, public :: set => seti, setc, setr
procedure, pass(sv) :: default => d_base_solver_default
procedure, pass(sv) :: descr => d_base_solver_descr
procedure, pass(sv) :: sizeof => d_base_solver_sizeof
procedure, pass(sv) :: descr => d_base_solver_descr
procedure, pass(sv) :: sizeof => d_base_solver_sizeof
end type mld_d_base_solver_type
type mld_d_base_smoother_type
class(mld_d_base_solver_type), allocatable :: sv
contains
procedure, pass(sm) :: check => d_base_smoother_check
procedure, pass(sm) :: dump => d_base_smoother_dmp
procedure, pass(sm) :: build => d_base_smoother_bld
procedure, pass(sm) :: apply => d_base_smoother_apply
@@ -206,23 +208,18 @@ module mld_d_prec_type
procedure, pass(sm) :: sizeof => d_base_smoother_sizeof
end type mld_d_base_smoother_type
type, extends(psb_d_base_prec_type) :: mld_dbaseprec_type
integer, allocatable :: iprcparm(:)
real(psb_dpk_), allocatable :: rprcparm(:)
end type mld_dbaseprec_type
type mld_donelev_type
class(mld_d_base_smoother_type), allocatable :: sm
integer :: sweeps, sweeps_pre, sweeps_post
type(mld_dbaseprec_type) :: prec
integer, allocatable :: iprcparm(:)
real(psb_dpk_), allocatable :: rprcparm(:)
type(mld_dml_parms) :: parms
type(psb_dspmat_type) :: ac
type(psb_desc_type) :: desc_ac
type(psb_dspmat_type), pointer :: base_a => null()
type(psb_desc_type), pointer :: base_desc => null()
type(psb_dlinmap_type) :: map
contains
procedure, pass(lv) :: descr => d_base_onelev_descr
procedure, pass(lv) :: default => d_base_onelev_default
procedure, pass(lv) :: check => d_base_onelev_check
procedure, pass(lv) :: dump => d_base_onelev_dump
procedure, pass(lv) :: seti => d_base_onelev_seti
procedure, pass(lv) :: setr => d_base_onelev_setr
@@ -243,14 +240,18 @@ module mld_d_prec_type
& d_base_solver_free, d_base_solver_seti, &
& d_base_solver_setc, d_base_solver_setr, &
& d_base_solver_descr, d_base_solver_sizeof, &
& d_base_solver_default, d_base_solver_dmp, &
& d_base_solver_default, d_base_solver_check,&
& d_base_solver_dmp, &
& d_base_smoother_bld, d_base_smoother_apply, &
& d_base_smoother_free, d_base_smoother_seti, &
& d_base_smoother_setc, d_base_smoother_setr,&
& d_base_smoother_descr, d_base_smoother_sizeof, &
& d_base_smoother_default, d_base_smoother_dmp, &
& d_base_onelev_dump, d_base_onelev_seti, &
& d_base_onelev_setr, d_base_onelev_setc
& d_base_smoother_default, d_base_smoother_check, &
& d_base_smoother_dmp, &
& d_base_onelev_seti, d_base_onelev_setc, &
& d_base_onelev_setr, d_base_onelev_check, &
& d_base_onelev_default, d_base_onelev_dump, &
& d_base_onelev_descr
!
@@ -259,11 +260,7 @@ module mld_d_prec_type
!
interface mld_precfree
module procedure mld_dbase_precfree, mld_d_onelev_precfree, mld_dprec_free
end interface
interface mld_nullify_baseprec
module procedure mld_nullify_dbaseprec
module procedure mld_d_onelev_precfree, mld_dprec_free
end interface
interface mld_nullify_onelevprec
@@ -275,7 +272,7 @@ module mld_d_prec_type
end interface
interface mld_sizeof
module procedure mld_dprec_sizeof, mld_dbaseprec_sizeof, mld_d_onelev_prec_sizeof
module procedure mld_dprec_sizeof, mld_d_onelev_prec_sizeof
end interface
interface mld_precaply
@@ -322,40 +319,6 @@ contains
end if
end function mld_dprec_sizeof
function mld_dbaseprec_sizeof(prec) result(val)
implicit none
type(mld_dbaseprec_type), intent(in) :: prec
integer(psb_long_int_k_) :: val
integer :: 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_dp * size(prec%rprcparm)
!!$ if (allocated(prec%d)) val = val + psb_sizeof_dp * 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
end function mld_dbaseprec_sizeof
function mld_d_onelev_prec_sizeof(prec) result(val)
implicit none
@@ -363,14 +326,7 @@ contains
integer(psb_long_int_k_) :: val
integer :: i
val = mld_sizeof(prec%prec)
if (allocated(prec%iprcparm)) &
& val = val + psb_sizeof_int * size(prec%iprcparm)
!!$ if (allocated(prec%ilaggr)) &
!!$ & val = val + psb_sizeof_int * size(prec%ilaggr)
!!$ if (allocated(prec%nlaggr)) &
!!$ & val = val + psb_sizeof_int * size(prec%nlaggr)
if (allocated(prec%rprcparm)) val = val + psb_sizeof_dp * size(prec%rprcparm)
val = 0
val = val + psb_sizeof(prec%desc_ac)
val = val + psb_sizeof(prec%ac)
val = val + psb_sizeof(prec%map)
@@ -419,12 +375,12 @@ contains
if (iout_ < 0) iout_ = 6
ictxt = p%ictxt
if (allocated(p%precv)) then
!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data)
call psb_info(ictxt,me,np)
!
! The preconditioner description is printed by processor psb_root_.
! This agrees with the fact that all the parameters defining the
@@ -432,10 +388,18 @@ contains
! ensured by mld_precbld).
!
if (me == psb_root_) then
nlev = size(p%precv)
do ilev = 1, nlev
if (.not.allocated(p%precv(ilev)%sm)) then
info = 3111
write(iout_,*) ' ',name,&
& ': error: inconsistent MLPREC part, should call MLD_PRECINIT'
return
endif
end do
write(iout_,*)
write(iout_,'(a)') 'Preconditioner description'
nlev = size(p%precv)
if (nlev >= 1) then
!
! Print description of base preconditioner
@@ -455,16 +419,6 @@ contains
!
write(iout_,*)
write(iout_,*) 'Multilevel details'
do ilev = 2, nlev
if (.not.allocated(p%precv(ilev)%iprcparm)) then
info = 3111
write(iout_,*) ' ',name,&
& ': error: inconsistent MLPREC part, should call MLD_PRECINIT'
return
endif
end do
write(iout_,*) ' Number of levels: ',nlev
!
@@ -474,35 +428,31 @@ contains
!
ilev=2
call mld_ml_alg_descr(iout_,ilev,p%precv(ilev)%iprcparm, info,&
& dprcparm=p%precv(ilev)%rprcparm)
!!$
!!$ !
!!$ ! Coarse matrices are different at levels 2,...,nlev-1, hence related
!!$ ! info is printed separately
!!$ !
call p%precv(ilev)%parms%descr(iout_,info)
!
! Coarse matrices are different at levels 2,...,nlev-1, hence related
! info is printed separately
!
write(iout_,*)
do ilev = 2, nlev-1
call mld_ml_level_descr(iout_,ilev,p%precv(ilev)%iprcparm,&
& p%precv(ilev)%map%naggr,info,&
& dprcparm=p%precv(ilev)%rprcparm)
call p%precv(ilev)%sm%descr(info,iout=iout_)
write(iout_,*) ' Level ',ilev
call p%precv(ilev)%descr(info,iout=iout_)
end do
!!$
!!$ !
!!$ ! Print coarsest level details
!!$ !
!!$
!
! Print coarsest level details
!
! Should rework this.
ilev = nlev
write(iout_,*)
call mld_ml_new_coarse_descr(iout_,ilev,&
& p%precv(ilev)%iprcparm,&
& p%precv(ilev)%map%naggr,info,&
& dprcparm=p%precv(ilev)%rprcparm)
call p%precv(ilev)%sm%descr(info,iout=iout_)
write(iout_,*) ' Level ',ilev,' (coarsest)'
call p%precv(ilev)%parms%descr(iout_,info,coarse=.true.)
call p%precv(ilev)%descr(info,iout=iout_,coarse=.true.)
end if
endif
write(iout_,*)
else
@@ -528,64 +478,66 @@ contains
! info - integer, output.
! error code.
!
subroutine mld_dbase_precfree(p,info)
implicit none
type(mld_dbaseprec_type), intent(inout) :: p
subroutine d_base_onelev_descr(lv,info,iout,coarse)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_donelev_type), intent(in) :: lv
integer, intent(out) :: info
integer :: i
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
info = psb_success_
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_d_base_onelev_descr'
integer :: iout_
logical :: coarse_
! 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 p%av(i)%free()
!!$ if (info /= psb_success_) 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%rprcparm)) then
deallocate(p%rprcparm,stat=info)
call psb_erractionsave(err_act)
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
if (present(iout)) then
iout_ = iout
else
iout_ = 6
end if
!!$ 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_prec_status_) == mld_prec_built_) then
if (p%iprcparm(mld_sub_solve_) == mld_slu_) then
call mld_dslu_free(p%iprcparm(mld_slu_ptr_),info)
end if
if (p%iprcparm(mld_sub_solve_) == mld_sludist_) then
call mld_dsludist_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
if (lv%parms%ml_type > mld_no_ml_) then
if (allocated(lv%map%naggr)) then
write(iout_,*) ' Size of coarse matrix: ', &
& sum(lv%map%naggr(:))
write(iout_,*) ' Sizes of aggregates: ', &
& lv%map%naggr(:)
end if
if (lv%parms%aggr_kind /= mld_no_smooth_) then
write(iout_,*) ' Damping omega: ', &
& lv%parms%aggr_omega_val
end if
deallocate(p%iprcparm,stat=info)
end if
call mld_nullify_baseprec(p)
if (allocated(lv%sm)) &
& call lv%sm%descr(info,iout=iout_,coarse=coarse)
end subroutine mld_dbase_precfree
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_base_onelev_descr
subroutine mld_d_onelev_precfree(p,info)
use psb_sparse_mod
@@ -598,17 +550,14 @@ contains
info = psb_success_
! Actually we might just deallocate the top level array, except
! for the inner UMFPACK or SLU stuff
! for the inner UMFPACK or SLU stuff.
! We really need FINALs.
call p%sm%free(info)
call mld_precfree(p%prec,info)
call p%ac%free()
if (psb_is_ok_desc(p%desc_ac)) &
& 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.
@@ -623,13 +572,6 @@ contains
call mld_nullify_onelevprec(p)
end subroutine mld_d_onelev_precfree
subroutine mld_nullify_dbaseprec(p)
implicit none
type(mld_dbaseprec_type), intent(inout) :: p
end subroutine mld_nullify_dbaseprec
subroutine mld_nullify_d_onelevprec(p)
implicit none
@@ -722,6 +664,44 @@ contains
end subroutine d_base_smoother_apply
subroutine d_base_smoother_check(sm,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_base_smoother_type), intent(inout) :: sm
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_smoother_check'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sm%sv)) then
call sm%sv%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_base_smoother_check
subroutine d_base_smoother_seti(sm,what,val,info)
use psb_sparse_mod
@@ -901,7 +881,7 @@ contains
return
end subroutine d_base_smoother_free
subroutine d_base_smoother_descr(sm,info,iout)
subroutine d_base_smoother_descr(sm,info,iout,coarse)
use psb_sparse_mod
@@ -911,26 +891,34 @@ contains
class(mld_d_base_smoother_type), intent(in) :: sm
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_d_base_smoother_descr'
integer :: iout_
logical :: coarse_
call psb_erractionsave(err_act)
info = psb_success_
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
if (present(iout)) then
iout_ = iout
else
iout_ = 6
end if
write(iout_,*) 'Base smoother with local solver'
if (.not.coarse_) &
& write(iout_,*) 'Base smoother with local solver'
if (allocated(sm%sv)) then
call sm%sv%descr(info,iout)
call sm%sv%descr(info,iout,coarse)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Local solver')
@@ -970,6 +958,8 @@ contains
class(mld_d_base_smoother_type), intent(inout) :: sm
! Do nothing for base version
if (allocated(sm%sv)) call sm%sv%default()
return
end subroutine d_base_smoother_default
@@ -991,7 +981,7 @@ contains
call psb_erractionsave(err_act)
info = 700
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
@@ -1026,7 +1016,7 @@ contains
call psb_erractionsave(err_act)
info = 700
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
@@ -1042,6 +1032,35 @@ contains
return
end subroutine d_base_solver_bld
subroutine d_base_solver_check(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_base_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_base_solver_check
subroutine d_base_solver_seti(sv,what,val,info)
@@ -1056,22 +1075,10 @@ contains
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_solver_seti'
call psb_erractionsave(err_act)
info = 700
call psb_errpush(info,name)
goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
! Correct action here is doing nothing.
info = 0
return
end subroutine d_base_solver_seti
@@ -1086,14 +1093,18 @@ contains
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
Integer :: err_act, ival
character(len=20) :: name='d_base_solver_setc'
call psb_erractionsave(err_act)
info = 700
call psb_errpush(info,name)
goto 9999
info = psb_success_
call mld_stringval(val,ival,info)
if (info == psb_success_) call sv%set(what,ival,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -1121,21 +1132,10 @@ contains
Integer :: err_act
character(len=20) :: name='d_base_solver_setr'
call psb_erractionsave(err_act)
info = 700
call psb_errpush(info,name)
goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
! Correct action here is doing nothing.
info = 0
return
end subroutine d_base_solver_setr
@@ -1153,7 +1153,7 @@ contains
call psb_erractionsave(err_act)
info = 700
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
@@ -1169,7 +1169,7 @@ contains
return
end subroutine d_base_solver_free
subroutine d_base_solver_descr(sv,info,iout)
subroutine d_base_solver_descr(sv,info,iout,coarse)
use psb_sparse_mod
@@ -1179,6 +1179,7 @@ contains
class(mld_d_base_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
@@ -1189,7 +1190,7 @@ contains
call psb_erractionsave(err_act)
info = 700
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
@@ -1244,7 +1245,7 @@ contains
type is (mld_dprec_type)
call mld_precaply(prec,x,y,desc_data,info,trans,work)
class default
info = 700
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
end select
@@ -1278,7 +1279,7 @@ contains
type is (mld_dprec_type)
call mld_precaply(prec,x,desc_data,info,trans)
class default
info = 700
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
end select
@@ -1296,6 +1297,82 @@ contains
end subroutine mld_d_apply1v
subroutine d_base_onelev_check(lv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_donelev_type), intent(inout) :: lv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_onelev_check'
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(lv%parms%sweeps,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(lv%parms%sweeps_pre,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(lv%parms%sweeps_post,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
if (allocated(lv%sm)) then
call lv%sm%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_base_onelev_check
subroutine d_base_onelev_default(lv)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_donelev_type), intent(inout) :: lv
lv%parms%sweeps = 1
lv%parms%sweeps_pre = 1
lv%parms%sweeps_post = 1
lv%parms%ml_type = mld_mult_ml_
lv%parms%aggr_alg = mld_dec_aggr_
lv%parms%aggr_kind = mld_smooth_prol_
lv%parms%coarse_mat = mld_distr_mat_
lv%parms%smoother_pos = mld_twoside_smooth_
lv%parms%aggr_omega_alg = mld_eig_est_
lv%parms%aggr_eig = mld_max_norm_
lv%parms%aggr_filter = mld_no_filter_mat_
lv%parms%aggr_omega_val = dzero
lv%parms%aggr_thresh = dzero
if (allocated(lv%sm)) call lv%sm%default()
return
end subroutine d_base_onelev_default
subroutine d_base_onelev_seti(lv,what,val,info)
use psb_sparse_mod
@@ -1314,14 +1391,45 @@ contains
info = psb_success_
select case (what)
case (mld_smoother_sweeps_)
lv%sweeps = val
lv%sweeps_pre = val
lv%sweeps_post = val
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
lv%parms%sweeps_post = val
case (mld_smoother_sweeps_pre_)
lv%sweeps_pre = val
lv%parms%sweeps_pre = val
case (mld_smoother_sweeps_post_)
lv%sweeps_post = val
lv%parms%sweeps_post = val
case (mld_ml_type_)
lv%parms%ml_type = val
case (mld_aggr_alg_)
lv%parms%aggr_alg = val
case (mld_aggr_kind_)
lv%parms%aggr_kind = val
case (mld_coarse_mat_)
lv%parms%coarse_mat = val
case (mld_smoother_pos_)
lv%parms%smoother_pos = val
case (mld_aggr_omega_alg_)
lv%parms%aggr_omega_alg= val
case (mld_aggr_eig_)
lv%parms%aggr_eig = val
case (mld_aggr_filter_)
lv%parms%aggr_filter = val
case (mld_coarse_solve_)
lv%parms%coarse_solve = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
@@ -1353,14 +1461,15 @@ contains
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_onelev_setc'
integer :: ival
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
call mld_stringval(val,ival,info)
if (info == psb_success_) call lv%set(what,ival,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@@ -1393,11 +1502,21 @@ contains
info = psb_success_
select case (what)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
if (info /= psb_success_) goto 9999
case (mld_aggr_omega_val_)
lv%parms%aggr_omega_val= val
case (mld_aggr_thresh_)
lv%parms%aggr_thresh = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
if (info /= psb_success_) goto 9999
end select
call psb_erractionrestore(err_act)
return
@@ -1444,6 +1563,7 @@ contains
end subroutine mld_d_dump
subroutine d_base_onelev_dump(lv,level,info,prefix,head,ac,smoother,solver)
use psb_sparse_mod
implicit none
@@ -1574,61 +1694,5 @@ contains
end subroutine d_base_solver_dmp
!!$
!!$
!!$ subroutine mld_d_precdump_fact(prec,info,istart,iend,prefix,head)
!!$ use psb_base_mod
!!$ implicit none
!!$ type(mld_dprec_type), intent(in) :: prec
!!$ integer, intent(out) :: info
!!$ integer, intent(in), optional :: istart, iend
!!$ character(len=*), intent(in), optional :: prefix,head
!!$ integer :: i, j, il1, iln, lname, lev
!!$ integer :: icontxt,iam, np
!!$ character(len=80) :: prefix_
!!$ character(len=120) :: fname ! len should be at least 20 more than
!!$ ! len of prefix_
!!$
!!$ info = 0
!!$
!!$ if (.not.mld_is_asb(prec)) then
!!$ info = -1
!!$ write(psb_err_unit,*) 'Trying to dump a non-built preconditioner'
!!$ return
!!$ end if
!!$
!!$ il1 = 1
!!$ iln = size(prec%precv)
!!$ if (present(istart)) then
!!$ il1 = max(1,istart)
!!$ end if
!!$ if (present(iend)) then
!!$ iln = min(iln, iend)
!!$ end if
!!$ if (present(prefix)) then
!!$ prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
!!$ else
!!$ prefix_ = "dump_fact_d"
!!$ end if
!!$
!!$ icontxt = psb_cd_get_context(prec%precv(1)%prec%desc_data)
!!$ call psb_info(icontxt,iam,np)
!!$ lname = len_trim(prefix_)
!!$ fname = trim(prefix_)
!!$ write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
!!$ lname = lname + 5
!!$ do lev=il1, iln
!!$ write(fname(lname+1:),'(a,i3.3,a)')'_l',lev,'_lower.mtx'
!!$ if (psb_is_asb(prec%precv(lev)%prec%av(mld_l_pr_))) &
!!$ & call psb_csprt(fname,prec%precv(lev)%prec%av(mld_l_pr_),head=head)
!!$ write(fname(lname+1:),'(a,i3.3,a)')'_l',lev,'_diag.mtx'
!!$ if (allocated(prec%precv(lev)%prec%d)) &
!!$ & call psb_geprt(fname,prec%precv(lev)%prec%d,head=head)
!!$ write(fname(lname+1:),'(a,i3.3,a)')'_l',lev,'_upper.mtx'
!!$ if (psb_is_asb(prec%precv(lev)%prec%av(mld_u_pr_))) &
!!$ & call psb_csprt(fname,prec%precv(lev)%prec%av(mld_u_pr_),head=head)
!!$ end do
!!$
!!$ end subroutine mld_d_precdump_fact
end module mld_d_prec_type
mlprec/mld_d_slu_solver.f90
+464
View File
@@ -0,0 +1,464 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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 mld_d_slu_solver
use iso_c_binding
use mld_d_prec_type
type, extends(mld_d_base_solver_type) :: mld_d_slu_solver_type
type(c_ptr) :: lufactors=c_null_ptr
integer(c_long_long) :: symbsize=0, numsize=0
contains
procedure, pass(sv) :: build => d_slu_solver_bld
procedure, pass(sv) :: apply => d_slu_solver_apply
procedure, pass(sv) :: free => d_slu_solver_free
procedure, pass(sv) :: seti => d_slu_solver_seti
procedure, pass(sv) :: setc => d_slu_solver_setc
procedure, pass(sv) :: setr => d_slu_solver_setr
procedure, pass(sv) :: descr => d_slu_solver_descr
procedure, pass(sv) :: sizeof => d_slu_solver_sizeof
end type mld_d_slu_solver_type
private :: d_slu_solver_bld, d_slu_solver_apply, &
& d_slu_solver_free, d_slu_solver_seti, &
& d_slu_solver_setc, d_slu_solver_setr,&
& d_slu_solver_descr, d_slu_solver_sizeof
interface
function mld_dslu_fact(n,nnz,values,rowptr,colind,&
& lufactors)&
& bind(c,name='mld_dslu_fact') result(info)
use iso_c_binding
integer(c_int), value :: n,nnz
integer(c_int) :: info
!integer(c_long_long) :: ssize, nsize
integer(c_int) :: rowptr(*),colind(*)
real(c_double) :: values(*)
type(c_ptr) :: lufactors
end function mld_dslu_fact
end interface
interface
function mld_dslu_solve(itrans,n,x, b, ldb, lufactors)&
& bind(c,name='mld_dslu_solve') result(info)
use iso_c_binding
integer(c_int) :: info
integer(c_int), value :: itrans,n,ldb
real(c_double) :: x(*), b(ldb,*)
type(c_ptr), value :: lufactors
end function mld_dslu_solve
end interface
interface
function mld_dslu_free(lufactors)&
& bind(c,name='mld_dslu_free') result(info)
use iso_c_binding
integer(c_int) :: info
type(c_ptr), value :: lufactors
end function mld_dslu_free
end interface
contains
subroutine d_slu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_d_slu_solver_type), intent(in) :: sv
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer :: n_row,n_col
real(psb_dpk_), pointer :: ww(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_slu_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,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)
else
allocate(ww(n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
select case(trans_)
case('N')
info = mld_dslu_solve(0,n_row,ww,x,n_row,sv%lufactors)
case('T','C')
info = mld_dslu_solve(1,n_row,ww,x,n_row,sv%lufactors)
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in subsolve')
goto 9999
endif
if (n_col > size(work)) then
deallocate(ww)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_slu_solver_apply
subroutine d_slu_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_d_slu_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target, optional :: b
! Local variables
type(psb_dspmat_type) :: atmp
type(psb_d_csr_sparse_mat) :: acsr
integer :: n_row,n_col, nrow_a, nztota
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_slu_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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),' start'
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
if (psb_toupper(upd) == 'F') then
call a%cscnv(atmp,info,type='coo')
call psb_rwextd(n_row,atmp,info,b=b)
call atmp%cscnv(info,type='csr',dupl=psb_dupl_add_)
call atmp%mv_to(acsr)
nrow_a = acsr%get_nrows()
nztota = acsr%get_nzeros()
! Fix the entres to call C-base SuperLU
acsr%ja(:) = acsr%ja(:) - 1
acsr%irp(:) = acsr%irp(:) - 1
info = mld_dslu_fact(nrow_a,nztota,acsr%val,&
& acsr%irp,acsr%ja,sv%lufactors)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_dslu_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call acsr%free()
call atmp%free()
else
! ?
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
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 == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_slu_solver_bld
subroutine d_slu_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_slu_solver_seti'
info = psb_success_
call psb_erractionsave(err_act)
select case(what)
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_slu_solver_seti
subroutine d_slu_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_slu_solver_setc'
info = psb_success_
call psb_erractionsave(err_act)
call mld_stringval(val,ival,info)
if (info == psb_success_) call sv%set(what,ival,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_slu_solver_setc
subroutine d_slu_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_slu_solver_setr'
call psb_erractionsave(err_act)
info = psb_success_
select case(what)
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
!!$ goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_slu_solver_setr
subroutine d_slu_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_slu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_slu_solver_free'
call psb_erractionsave(err_act)
info = mld_dslu_free(sv%lufactors)
if (info /= psb_success_) goto 9999
sv%lufactors = c_null_ptr
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_slu_solver_free
subroutine d_slu_solver_descr(sv,info,iout,coarse)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_slu_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_d_slu_solver_descr'
integer :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' SuperLU Sparse Factorization Solver. '
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_slu_solver_descr
function d_slu_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_d_slu_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 2*psb_sizeof_int + psb_sizeof_dp
val = val + sv%symbsize
val = val + sv%numsize
return
end function d_slu_solver_sizeof
end module mld_d_slu_solver
mlprec/mld_d_sludist_solver.f90
+468
View File
@@ -0,0 +1,468 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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 mld_d_sludist_solver
use iso_c_binding
use mld_d_prec_type
type, extends(mld_d_base_solver_type) :: mld_d_sludist_solver_type
type(c_ptr) :: lufactors=c_null_ptr
integer(c_long_long) :: symbsize=0, numsize=0
contains
procedure, pass(sv) :: build => d_sludist_solver_bld
procedure, pass(sv) :: apply => d_sludist_solver_apply
procedure, pass(sv) :: free => d_sludist_solver_free
procedure, pass(sv) :: seti => d_sludist_solver_seti
procedure, pass(sv) :: setc => d_sludist_solver_setc
procedure, pass(sv) :: setr => d_sludist_solver_setr
procedure, pass(sv) :: descr => d_sludist_solver_descr
procedure, pass(sv) :: sizeof => d_sludist_solver_sizeof
end type mld_d_sludist_solver_type
private :: d_sludist_solver_bld, d_sludist_solver_apply, &
& d_sludist_solver_free, d_sludist_solver_seti, &
& d_sludist_solver_setc, d_sludist_solver_setr,&
& d_sludist_solver_descr, d_sludist_solver_sizeof
interface
function mld_dsludist_fact(n,nnz,values,rowptr,colind,&
& lufactors)&
& bind(c,name='mld_dsludist_fact') result(info)
use iso_c_binding
integer(c_int), value :: n,nnz
integer(c_int) :: info
!integer(c_long_long) :: ssize, nsize
integer(c_int) :: rowptr(*),colind(*)
real(c_double) :: values(*)
type(c_ptr) :: lufactors
end function mld_dsludist_fact
end interface
interface
function mld_dsludist_solve(itrans,n,x, b, ldb, lufactors)&
& bind(c,name='mld_dsludist_solve') result(info)
use iso_c_binding
integer(c_int) :: info
integer(c_int), value :: itrans,n,ldb
real(c_double) :: x(*), b(ldb,*)
type(c_ptr), value :: lufactors
end function mld_dsludist_solve
end interface
interface
function mld_dsludist_free(lufactors)&
& bind(c,name='mld_dsludist_free') result(info)
use iso_c_binding
integer(c_int) :: info
type(c_ptr), value :: lufactors
end function mld_dsludist_free
end interface
contains
subroutine d_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_d_sludist_solver_type), intent(in) :: sv
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer :: n_row,n_col
real(psb_dpk_), pointer :: ww(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_sludist_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,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)
else
allocate(ww(n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
select case(trans_)
case('N')
info = mld_dsludist_solve(0,n_row,ww,x,n_row,sv%lufactors)
case('T','C')
info = mld_dsludist_solve(1,n_row,ww,x,n_row,sv%lufactors)
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in subsolve')
goto 9999
endif
if (n_col > size(work)) then
deallocate(ww)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_sludist_solver_apply
subroutine d_sludist_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_d_sludist_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target, optional :: b
! Local variables
type(psb_dspmat_type) :: atmp
type(psb_d_csr_sparse_mat) :: acsr
integer :: n_row,n_col, nrow_a, nztota
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_sludist_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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),' start'
write(0,*) 'SLUDIST INTERFACE IS CURRENTLY BROKEN. TO BE FIXED'
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
if (psb_toupper(upd) == 'F') then
call a%cscnv(atmp,info,type='coo')
call psb_rwextd(n_row,atmp,info,b=b)
call atmp%cscnv(info,type='csr',dupl=psb_dupl_add_)
call atmp%mv_to(acsr)
nrow_a = acsr%get_nrows()
nztota = acsr%get_nzeros()
! Fix the entres to call C-base SuperLU
acsr%ja(:) = acsr%ja(:) - 1
acsr%irp(:) = acsr%irp(:) - 1
info = mld_dsludist_fact(nrow_a,nztota,acsr%val,&
& acsr%irp,acsr%ja,sv%lufactors)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_dsludist_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call acsr%free()
call atmp%free()
else
! ?
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
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 == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_sludist_solver_bld
subroutine d_sludist_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_sludist_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_sludist_solver_seti'
info = psb_success_
call psb_erractionsave(err_act)
select case(what)
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_sludist_solver_seti
subroutine d_sludist_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_sludist_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_sludist_solver_setc'
info = psb_success_
call psb_erractionsave(err_act)
call mld_stringval(val,ival,info)
if (info == psb_success_) call sv%set(what,ival,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_sludist_solver_setc
subroutine d_sludist_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_sludist_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_sludist_solver_setr'
call psb_erractionsave(err_act)
info = psb_success_
select case(what)
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
!!$ goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_sludist_solver_setr
subroutine d_sludist_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_sludist_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_sludist_solver_free'
call psb_erractionsave(err_act)
info = mld_dsludist_free(sv%lufactors)
if (info /= psb_success_) goto 9999
sv%lufactors = c_null_ptr
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_sludist_solver_free
subroutine d_sludist_solver_descr(sv,info,iout,coarse)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_d_sludist_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_d_sludist_solver_descr'
integer :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' SuperLU Sparse Factorization Solver. '
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_sludist_solver_descr
function d_sludist_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_d_sludist_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 2*psb_sizeof_int + psb_sizeof_dp
val = val + sv%symbsize
val = val + sv%numsize
return
end function d_sludist_solver_sizeof
end module mld_d_sludist_solver
mlprec/mld_d_umf_solver.f90
+2 -5
View File
@@ -49,12 +49,8 @@ module mld_d_umf_solver
use mld_d_prec_type
type, extends(mld_d_base_solver_type) :: mld_d_umf_solver_type
!!$ type(psb_dspmat_type) :: l, u
!!$ real(psb_dpk_), allocatable :: d(:)
type(c_ptr) :: symbolic=c_null_ptr, numeric=c_null_ptr
integer(c_long_long) :: symbsize=0, numsize=0
!!$ integer :: fact_type, fill_in
!!$ real(psb_dpk_) :: thresh
contains
procedure, pass(sv) :: build => d_umf_solver_bld
procedure, pass(sv) :: apply => d_umf_solver_apply
@@ -414,7 +410,7 @@ contains
return
end subroutine d_umf_solver_free
subroutine d_umf_solver_descr(sv,info,iout)
subroutine d_umf_solver_descr(sv,info,iout,coarse)
use psb_sparse_mod
@@ -424,6 +420,7 @@ contains
class(mld_d_umf_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
mlprec/mld_daggrmap_bld.f90
+2 -2
View File
@@ -82,7 +82,7 @@
subroutine mld_daggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_daggrmap_bld
use mld_d_inner_mod, mld_protect_name => mld_daggrmap_bld
implicit none
@@ -165,7 +165,7 @@ contains
subroutine mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
use psb_sparse_mod
use mld_inner_mod !, mld_protect_name => mld_daggrmap_bld
use mld_d_inner_mod !, mld_protect_name => mld_daggrmap_bld
implicit none
mlprec/mld_daggrmat_asb.f90
+2 -2
View File
@@ -101,7 +101,7 @@
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_daggrmat_asb
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_asb
implicit none
@@ -126,7 +126,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_info(ictxt, me, np)
select case (p%iprcparm(mld_aggr_kind_))
select case (p%parms%aggr_kind)
case (mld_no_smooth_)
call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
mlprec/mld_daggrmat_minnrg_asb.F90
+5 -5
View File
@@ -58,7 +58,7 @@
! 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_omega_alg_), specified by the user
! according to the value of p%parms%aggr_omega_alg, specified by the user
! through mld_dprecinit and mld_dprecset.
!
! This routine can also build A_C according to a "bizarre" aggregation algorithm,
@@ -67,7 +67,7 @@
! 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_),
! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_dprecinit and mld_dprecset.
!
! For more details see
@@ -100,7 +100,7 @@
!
subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_daggrmat_minnrg_asb
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_minnrg_asb
#ifdef MPI_MOD
use mpi
@@ -185,7 +185,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
!!$ naggrm1 = sum(nlaggr(1:me))
!!$ naggrp1 = sum(nlaggr(1:me+1))
!!$
!!$ filter_mat = (p%iprcparm(mld_aggr_filter_) == mld_filter_mat_)
!!$ filter_mat = (p%parms%aggr_filter == mld_filter_mat_)
!!$
!!$ ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
!!$ call psb_halo(ilaggr,desc_a,info)
@@ -699,7 +699,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
!!$
!!$
!!$
!!$ select case(p%iprcparm(mld_coarse_mat_))
!!$ select case(p%parms%coarse_mat)
!!$
!!$ case(mld_distr_mat_)
!!$
mlprec/mld_daggrmat_nosmth_asb.F90
+6 -6
View File
@@ -50,7 +50,7 @@
! 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_),
! replicated on each of them, according to the value of p%parms%coarse_mat
! specified by the user through mld_dprecinit and mld_dprecset.
!
! For details see
@@ -83,7 +83,7 @@
!
subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_daggrmat_nosmth_asb
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_nosmth_asb
#ifdef MPI_MOD
use mpi
@@ -136,7 +136,7 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1=sum(nlaggr(1:me))
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
do i=1, nrow
ilaggr(i) = ilaggr(i) + naggrm1
end do
@@ -148,7 +148,7 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
call acoo1%allocate(ncol,ntaggr,ncol)
else
call acoo1%allocate(ncol,naggr,ncol)
@@ -180,7 +180,7 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call bcoo%fix(info)
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
@@ -217,7 +217,7 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call ac_coo%fix(info)
call p%ac%mv_from(ac_coo)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
else if (p%parms%coarse_mat == mld_distr_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
mlprec/mld_daggrmat_smth_asb.F90
+22 -22
View File
@@ -58,7 +58,7 @@
! 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_omega_alg_), specified by the user
! according to the value of p%parms%aggr_omega_alg, specified by the user
! through mld_dprecinit and mld_dprecset.
!
! This routine can also build A_C according to a "bizarre" aggregation algorithm,
@@ -67,7 +67,7 @@
! 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_),
! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_dprecinit and mld_dprecset.
!
! For more details see
@@ -100,7 +100,7 @@
!
subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_daggrmat_smth_asb
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_smth_asb
#ifdef MPI_MOD
use mpi
@@ -150,7 +150,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
theta = p%rprcparm(mld_aggr_thresh_)
theta = p%parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
@@ -165,11 +165,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(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_)) )
ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.&
& ( (p%parms%aggr_kind == mld_biz_prol_).and.&
& (p%parms%coarse_mat == mld_repl_mat_)) )
filter_mat = (p%iprcparm(mld_aggr_filter_) == mld_filter_mat_)
filter_mat = (p%parms%aggr_filter == mld_filter_mat_)
if (ml_global_nmb) then
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
@@ -283,11 +283,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info /= psb_success_) goto 9999
if (p%iprcparm(mld_aggr_omega_alg_) == mld_eig_est_) then
if (p%parms%aggr_omega_alg == mld_eig_est_) then
if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then
if (p%parms%aggr_eig == mld_max_norm_) then
if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
if (p%parms%aggr_kind == mld_biz_prol_) then
!
! This only works with CSR
@@ -317,7 +317,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
omega = 4.d0/(3.d0*anorm)
p%rprcparm(mld_aggr_omega_val_) = omega
p%parms%aggr_omega_val = omega
else
info = psb_err_internal_error_
@@ -325,11 +325,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
else if (p%iprcparm(mld_aggr_omega_alg_) == mld_user_choice_) then
else if (p%parms%aggr_omega_alg == mld_user_choice_) then
omega = p%rprcparm(mld_aggr_omega_val_)
omega = p%parms%aggr_omega_val
else if (p%iprcparm(mld_aggr_omega_alg_) /= mld_user_choice_) then
else if (p%parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999
@@ -438,9 +438,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_numbmm(a,am1,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',p%iprcparm(mld_aggr_kind_), mld_smooth_prol_
& 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
if (p%parms%aggr_kind == mld_smooth_prol_) then
call am2%transp(am1)
call am2%mv_to(acoo2)
nzl = acoo2%get_nzeros()
@@ -472,13 +472,13 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
if (p%parms%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 == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call am4%free()
else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
else if (p%parms%aggr_kind == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info)
endif
if(info /= psb_success_) then
@@ -501,11 +501,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
select case(p%iprcparm(mld_aggr_kind_))
select case(p%parms%aggr_kind)
case(mld_smooth_prol_)
select case(p%iprcparm(mld_coarse_mat_))
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
@@ -593,7 +593,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
case(mld_biz_prol_)
select case(p%iprcparm(mld_coarse_mat_))
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
mlprec/mld_dcoarse_bld.f90
+14 -19
View File
@@ -68,7 +68,7 @@
subroutine mld_dcoarse_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dcoarse_bld
use mld_d_inner_mod, mld_protect_name => mld_dcoarse_bld
implicit none
@@ -90,30 +90,25 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info)
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',&
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
call mld_check_def(p%iprcparm(mld_aggr_alg_),'Aggregation',&
call mld_check_def(p%parms%aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_aggr_alg)
call mld_check_def(p%iprcparm(mld_aggr_kind_),'Smoother',&
call mld_check_def(p%parms%aggr_kind,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_kind)
call mld_check_def(p%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
call mld_check_def(p%iprcparm(mld_aggr_filter_),'Use filtered matrix',&
call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',&
& mld_no_filter_mat_,is_legal_aggr_filter)
call mld_check_def(p%iprcparm(mld_smoother_pos_),'smooth_pos',&
call mld_check_def(p%parms%smoother_pos,'smooth_pos',&
& mld_pre_smooth_,is_legal_ml_smooth_pos)
call mld_check_def(p%iprcparm(mld_aggr_omega_alg_),'Omega Alg.',&
call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',&
& mld_eig_est_,is_legal_ml_aggr_omega_alg)
call mld_check_def(p%iprcparm(mld_aggr_eig_),'Eigenvalue estimate',&
call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',&
& mld_max_norm_,is_legal_ml_aggr_eig)
call mld_check_def(p%rprcparm(mld_aggr_omega_val_),'Omega',dzero,is_legal_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',dzero,is_legal_aggr_thrs)
call mld_check_def(p%parms%aggr_omega_val,'Omega',dzero,is_legal_omega)
call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_aggr_thrs)
!
! Build a mapping between the row indices of the fine-level matrix
@@ -121,7 +116,7 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info)
! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level.
!
call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),&
call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_thresh,&
& a,desc_a,ilaggr,nlaggr,info)
if (info /= psb_success_) then
@@ -146,7 +141,7 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info)
!
p%base_a => p%ac
p%base_desc => p%desc_ac
call psb_erractionrestore(err_act)
return
mlprec/mld_dilu0_fact.f90
+1 -1
View File
@@ -102,7 +102,7 @@
subroutine mld_dilu0_fact(ialg,a,l,u,d,info,blck, upd)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_dilu0_fact
use mld_d_inner_mod!, mld_protect_name => mld_dilu0_fact
implicit none
mlprec/mld_diluk_fact.f90
+1 -1
View File
@@ -99,7 +99,7 @@
subroutine mld_diluk_fact(fill_in,ialg,a,l,u,d,info,blck)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_diluk_fact
use mld_d_inner_mod!, mld_protect_name => mld_diluk_fact
implicit none
mlprec/mld_dilut_fact.f90
+1 -1
View File
@@ -95,7 +95,7 @@
subroutine mld_dilut_fact(fill_in,thres,a,l,u,d,info,blck)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_dilut_fact
use mld_d_inner_mod!, mld_protect_name => mld_dilut_fact
implicit none
mlprec/mld_dmlprec_aply.f90
+20 -27
View File
@@ -315,7 +315,7 @@
subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dmlprec_aply
use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply
implicit none
@@ -455,13 +455,12 @@ contains
end if
end if
select case(p%precv(level)%iprcparm(mld_ml_type_))
select case(p%precv(level)%parms%ml_type)
case(mld_no_ml_)
!
! No preconditioning, should not really get here
!
write(0,*) 'MLD_NO_ML_ in inner_ml ',level
call psb_errpush(psb_err_internal_error_,name,&
& a_err='mld_no_ml_ in mlprc_aply?')
goto 9999
@@ -485,7 +484,7 @@ contains
end if
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -514,21 +513,18 @@ contains
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
write(0,*) me,' inner_ml: mult ', level
select case(p%precv(level)%iprcparm(mld_smoother_pos_))
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
select case (trans_)
case('N')
write(0,*) me,' inner_ml: post',level
if (level > 1) then
! Apply the restriction
call psb_map_X2Y(done,mlprec_wrk(level-1)%x2l,&
& dzero,mlprec_wrk(level)%x2l,&
& p%precv(level)%map,info,work=work)
write(0,*) me,' inner_ml: entry x2l:',mlprec_wrk(level)%x2l
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@@ -556,15 +552,14 @@ contains
& work=work,trans=trans)
if (info /= psb_success_) goto 9999
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
write(0,*) me,' inner_ml: apply ',level,' sweeps: ',sweeps
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
write(0,*) me,' inner_ml: apply ',level,' sweeps: ',sweeps
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -572,8 +567,6 @@ contains
end if
write(0,*) me,' inner_ml: exit y2l:',mlprec_wrk(level)%y2l
case('T','C')
! Post-smoothing transpose is pre-smoothing
@@ -598,9 +591,9 @@ contains
! Apply the base preconditioner
!
if (level < nlev) then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
@@ -658,9 +651,9 @@ contains
! Apply the base preconditioner
!
if (level < nlev) then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
@@ -725,13 +718,13 @@ contains
& work=work,trans=trans)
if (info /= psb_success_) goto 9999
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -775,12 +768,12 @@ contains
!
if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
end if
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
@@ -822,9 +815,9 @@ contains
! Apply the base preconditioner
!
if (trans == 'N') then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
end if
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,&
@@ -841,7 +834,7 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%iprcparm(mld_smoother_pos_),0,0,0,0/))
& i_Err=(/p%precv(level)%parms%smoother_pos,0,0,0,0/))
goto 9999
end select
@@ -849,7 +842,7 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%iprcparm(mld_ml_type_),0,0,0,0/))
& i_Err=(/p%precv(level)%parms%ml_type,0,0,0,0/))
goto 9999
end select
mlprec/mld_dmlprec_bld.f90
+201 -286
View File
@@ -40,7 +40,6 @@
!
! Subroutine: mld_dmlprec_bld
! Version: real
! Contains: subroutine init_baseprec_av
!
! This routine builds the preconditioner according to the requirements made by
! the user trough the subroutines mld_precinit and mld_precset.
@@ -67,13 +66,8 @@
subroutine mld_dmlprec_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dmlprec_bld
use mld_prec_mod
use mld_d_jac_smoother
use mld_d_as_smoother
use mld_d_diag_solver
use mld_d_ilu_solver
use mld_d_umf_solver
use mld_d_inner_mod, mld_protect_name => mld_dmlprec_bld
use mld_d_prec_mod
Implicit None
@@ -90,6 +84,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
integer :: ipv(mld_ifpsz_), val
integer :: int_err(5)
character :: upd_
type(mld_dml_parms) :: prm
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -153,239 +148,178 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
goto 9999
endif
if (iszv > 1) then
!
! Build the matrix and the transfer operators corresponding
! to the remaining levels
!
!
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%precv(1)%iprcparm(:) = ipv(:)
end if
!
! Finest level first; remember to fix base_a and base_desc
!
call init_baseprec_av(p%precv(1)%prec,info)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
if (iszv > 1) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv
!
! Build the matrix and the transfer operators corresponding
! to the remaining levels
!
!
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(i)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(i)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, resetting.'
p%precv(i)%iprcparm(:) = ipv(:)
call psb_bcast(ictxt,p%precv(1)%parms)
!
! Finest level first; remember to fix base_a and base_desc
!
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Sanity checks on the parameters
!
if (i<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%precv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
do i=2, iszv
!
! Check on the iprcparm contents: they should be the same
! on all processes.
!
call psb_bcast(ictxt,p%precv(1)%parms)
!
! Sanity checks on the parameters
!
if (i<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
!
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Init 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
if (i>2) then
if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then
newsz=i-1
end if
call psb_bcast(ictxt,newsz)
if (newsz > 0) exit
end if
end do
if (newsz > 0) then
if (me == 0) then
write(debug_unit,*) trim(name),&
&': Warning: aggregates from level ',&
& newsz
write(debug_unit,*) trim(name),&
&': to level ',&
& iszv,' coincide.'
write(debug_unit,*) trim(name),&
&': Number of levels actually used :',newsz
write(debug_unit,*)
end if
allocate(t_prec%precv(newsz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,newsz-1
call mld_move_alloc(p%precv(i),t_prec%precv(i),info)
end do
call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info)
do i=newsz+1, iszv
call mld_precfree(p%precv(i),info)
end do
call mld_move_alloc(t_prec,p,info)
! Ignore errors from transfer
info = psb_success_
!
! Restart
iszv = newsz
! Fix the pointers, but the level 1 should
! be already OK
do i=2, iszv - 1
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do
i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild')
goto 9999
endif
end if
end if
do i=1, iszv
!
! build the base preconditioner at level i
!
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
call mld_check_def(p%precv(i)%parms%sweeps,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(p%precv(i)%parms%sweeps_pre,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(p%precv(i)%parms%sweeps_post,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
if (.not.allocated(p%precv(i)%sm)) then
!! Error: should have called mld_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (.not.allocated(p%precv(i)%sm%sv)) then
!! Error: should have called mld_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
! Test version for beginning of OO stuff.
!
call init_baseprec_av(p%precv(i)%prec,info)
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,'F',info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Init upper level preconditioner')
& a_err='One level preconditioner build.')
goto 9999
endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Return from ',i,' call to mlprcbld ',info
if (i>2) then
if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then
newsz=i-1
end if
call psb_bcast(ictxt,newsz)
if (newsz > 0) exit
end if
end do
if (newsz > 0) then
if (me == 0) then
write(debug_unit,*) trim(name),&
&': Warning: aggregates from level ',&
& newsz
write(debug_unit,*) trim(name),&
&': to level ',&
& iszv,' coincide.'
write(debug_unit,*) trim(name),&
&': Number of levels actually used :',newsz
write(debug_unit,*)
end if
allocate(t_prec%precv(newsz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,newsz-1
call mld_move_alloc(p%precv(i),t_prec%precv(i),info)
end do
call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info)
do i=newsz+1, iszv
call mld_precfree(p%precv(i),info)
end do
call mld_move_alloc(t_prec,p,info)
! Ignore errors from transfer
info = psb_success_
!
! Restart
iszv = newsz
! Fix the pointers, but the level 1 should
! be already OK
do i=2, iszv - 1
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do
i = iszv
call check_coarse_lev(p%precv(i))
call init_baseprec_av(p%precv(i)%prec,info)
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild')
goto 9999
endif
end if
end if
do i=1, iszv
!
! build the base preconditioner at level i
!
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
select case(p%precv(i)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%precv(i)%prec%iprcparm(mld_sub_fillin_),&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%precv(i)%prec%rprcparm(mld_sub_iluthrs_),&
& 'Eps',dzero,is_legal_fact_thrs)
end select
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_),&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_pre_),&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_post_),&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
!
! Test version for beginning of OO stuff.
!
if (allocated(p%precv(i)%sm)) then
call p%precv(i)%sm%free(info)
if (info == psb_success_) deallocate(p%precv(i)%sm,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
end if
select case (p%precv(i)%prec%iprcparm(mld_smoother_type_))
case(mld_bjac_, mld_jac_)
allocate(mld_d_jac_smoother_type :: p%precv(i)%sm, stat=info)
case(mld_as_)
allocate(mld_d_as_smoother_type :: p%precv(i)%sm, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Smoother allocation error',info,&
& p%precv(i)%prec%iprcparm(mld_smoother_type_)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(i)%sm%set(mld_sub_restr_,p%precv(i)%prec%iprcparm(mld_sub_restr_),info)
call p%precv(i)%sm%set(mld_sub_prol_,p%precv(i)%prec%iprcparm(mld_sub_prol_),info)
call p%precv(i)%sm%set(mld_sub_ovr_,p%precv(i)%prec%iprcparm(mld_sub_ovr_),info)
select case (p%precv(i)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
allocate(mld_d_ilu_solver_type :: p%precv(i)%sm%sv, stat=info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_solve_,&
& p%precv(i)%prec%iprcparm(mld_sub_solve_),info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_fillin_,&
& p%precv(i)%prec%iprcparm(mld_sub_fillin_),info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_iluthrs_,&
& p%precv(i)%prec%rprcparm(mld_sub_iluthrs_),info)
case(mld_diag_scale_)
allocate(mld_d_diag_solver_type :: p%precv(i)%sm%sv, stat=info)
case(mld_umf_)
allocate(mld_d_umf_solver_type :: p%precv(i)%sm%sv, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Solver allocation error',info,&
& p%precv(i)%prec%iprcparm(mld_sub_solve_)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,'F',info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Return from ',i,' call to mlprcbld ',info
end do
call psb_erractionrestore(err_act)
return
@@ -400,86 +334,67 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
contains
subroutine init_baseprec_av(p,info)
type(mld_dbaseprec_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 /= psb_success_) return
!!$ endif
!!$ end if
!!$ if (.not.(allocated(p%av))) then
!!$ allocate(p%av(mld_max_avsz_),stat=info)
!!$ if (info /= psb_success_) return
!!$ end if
!!$ do k=1,size(p%av)
!!$ call psb_nullify_sp(p%av(k))
!!$ end do
end subroutine init_baseprec_av
subroutine check_coarse_lev(prec)
type(mld_donelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
val = prec%iprcparm(mld_coarse_solve_)
select case (val)
case(mld_jac_)
if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
end if
prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
case(mld_bjac_)
if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
& ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
!!$#if defined(HAVE_UMF_)
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$#elif defined(HAVE_SLU_)
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$#else
prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$#endif
end if
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
case(mld_umf_, mld_slu_)
if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
prec%prec%iprcparm(mld_sub_solve_) = val
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
end if
case(mld_sludist_)
if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
prec%prec%iprcparm(mld_sub_solve_) = val
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
prec%prec%iprcparm(mld_smoother_sweeps_) = 1
end if
end select
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_dmlprec_bld
mlprec/mld_dprecaply.f90
+3 -3
View File
@@ -74,7 +74,7 @@
subroutine mld_dprecaply(prec,x,y,desc_data,info,trans,work)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dprecaply
use mld_d_inner_mod, mld_protect_name => mld_dprecaply
implicit none
@@ -140,7 +140,7 @@ subroutine mld_dprecaply(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,&
& prec%precv(1)%iprcparm(mld_smoother_sweeps_), work_,info)
& prec%precv(1)%parms%sweeps, work_,info)
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
@@ -206,7 +206,7 @@ end subroutine mld_dprecaply
subroutine mld_dprecaply1(prec,x,desc_data,info,trans)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dprecaply1
use mld_d_inner_mod, mld_protect_name => mld_dprecaply1
implicit none
mlprec/mld_dprecbld.f90
+25 -114
View File
@@ -61,14 +61,9 @@
subroutine mld_dprecbld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod
use mld_prec_mod, mld_protect_name => mld_dprecbld
use mld_d_jac_smoother
use mld_d_as_smoother
use mld_d_diag_solver
use mld_d_ilu_solver
use mld_d_umf_solver
use mld_d_inner_mod
use mld_d_prec_mod, mld_protect_name => mld_dprecbld
Implicit None
! Arguments
@@ -84,6 +79,7 @@ subroutine mld_dprecbld(a,desc_a,p,info)
integer :: ipv(mld_ifpsz_), val
integer :: int_err(5)
character :: upd_
type(mld_dml_parms) :: prm
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -105,7 +101,7 @@ subroutine mld_dprecbld(a,desc_a,p,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering '
!
! For the time being we are commenting out the UPDATE argument;
! 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_) &
@@ -139,7 +135,7 @@ subroutine mld_dprecbld(a,desc_a,p,info)
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
if (iszv <= 0) then
! Is this really possible? probably not.
info=psb_err_from_subroutine_
@@ -156,17 +152,8 @@ subroutine mld_dprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%precv(1)%iprcparm(:) = ipv(:)
end if
!
! Remember to fix base_a and base_desc
!
call init_baseprec_av(p%precv(1)%prec,info)
call psb_bcast(ictxt,p%precv(1)%parms)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
@@ -174,91 +161,35 @@ subroutine mld_dprecbld(a,desc_a,p,info)
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Build the base preconditioner
!
select case(p%precv(1)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%precv(1)%prec%iprcparm(mld_sub_fillin_),&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%precv(1)%prec%rprcparm(mld_sub_iluthrs_),&
& 'Eps',dzero,is_legal_fact_thrs)
end select
call mld_check_def(p%precv(1)%iprcparm(mld_smoother_sweeps_),&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
!
! Test version for beginning of OO stuff.
!
if (allocated(p%precv(1)%sm)) then
call p%precv(1)%sm%free(info)
if (info == psb_success_) deallocate(p%precv(1)%sm,stat=info)
call p%precv(1)%check(info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name,a_err='One level preconditioner build.')
write(0,*) ' Smoother check error',info
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner check.')
goto 9999
endif
end if
select case (p%precv(1)%prec%iprcparm(mld_smoother_type_))
case(mld_jac_, mld_bjac_)
allocate(mld_d_jac_smoother_type :: p%precv(1)%sm, stat=info)
case(mld_as_)
allocate(mld_d_as_smoother_type :: p%precv(1)%sm, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Smoother allocation error',info,&
& p%precv(1)%prec%iprcparm(mld_smoother_type_)
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(1)%sm%set(mld_sub_restr_,p%precv(1)%prec%iprcparm(mld_sub_restr_),info)
call p%precv(1)%sm%set(mld_sub_prol_,p%precv(1)%prec%iprcparm(mld_sub_prol_),info)
call p%precv(1)%sm%set(mld_sub_ovr_,p%precv(1)%prec%iprcparm(mld_sub_ovr_),info)
select case (p%precv(1)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
allocate(mld_d_ilu_solver_type :: p%precv(1)%sm%sv, stat=info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_solve_,&
& p%precv(1)%prec%iprcparm(mld_sub_solve_),info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_fillin_,&
& p%precv(1)%prec%iprcparm(mld_sub_fillin_),info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_iluthrs_,&
& p%precv(1)%prec%rprcparm(mld_sub_iluthrs_),info)
case(mld_diag_scale_)
allocate(mld_d_diag_solver_type :: p%precv(1)%sm%sv, stat=info)
case(mld_umf_)
allocate(mld_d_umf_solver_type :: p%precv(1)%sm%sv, stat=info)
case default
info = -1
end select
call p%precv(1)%sm%build(a,desc_a,upd_,info)
if (info /= psb_success_) then
write(0,*) ' Smoother build error',info
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
if (info /= psb_success_) then
write(0,*) ' Solver allocation error',info,&
& p%precv(1)%prec%iprcparm(mld_sub_solve_)
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(1)%sm%build(a,desc_a,upd_,info)
if (info /= psb_success_) then
write(0,*) ' Smoother build error',info
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
!
! Number of levels > 1
!
!
! Number of levels > 1
!
else if (iszv > 1) then
!
! Build the multilevel preconditioner
!
call mld_mlprec_bld(a,desc_a,p,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Multilevel preconditioner build.')
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Multilevel preconditioner build.')
goto 9999
endif
end if
@@ -274,25 +205,5 @@ subroutine mld_dprecbld(a,desc_a,p,info)
end if
return
contains
subroutine init_baseprec_av(p,info)
type(mld_dbaseprec_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 /= psb_success_) return
!!$ endif
!!$ end if
!!$ if (.not.(allocated(p%av))) then
!!$ allocate(p%av(mld_max_avsz_),stat=info)
!!$ if (info /= psb_success_) return
!!$ end if
!!$ do k=1,size(p%av)
!!$ call psb_nullify_sp(p%av(k))
!!$ end do
end subroutine init_baseprec_av
end subroutine mld_dprecbld
mlprec/mld_dprecinit.F90
+45 -174
View File
@@ -91,11 +91,18 @@
subroutine mld_dprecinit(p,ptype,info,nlev)
use psb_sparse_mod
use mld_prec_mod, mld_protect_name => mld_dprecinit
use mld_d_prec_mod, mld_protect_name => mld_dprecinit
use mld_d_jac_smoother
use mld_d_as_smoother
use mld_d_id_solver
use mld_d_diag_solver
use mld_d_ilu_solver
#if defined(HAVE_UMF_)
use mld_d_umf_solver
#endif
#if defined(HAVE_SLU_)
use mld_d_slu_solver
#endif
implicit none
@@ -119,104 +126,41 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
endif
select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC')
case ('NOPREC','NONE')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_d_base_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_noprec_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_d_id_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('JAC','DIAG','JACOBI')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_d_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_d_diag_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('BJAC')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_d_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_d_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('AS')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_d_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_d_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('ML')
@@ -228,110 +172,37 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
end if
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
!!$ write(0,*) 'Check 1: ',allocated(p%precv(1)%sm)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
!!$ write(0,*) 'Check 2: ',allocated(p%precv(1)%sm)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
!!$ write(0,*) 'Check 3: ',allocated(p%precv(1)%sm)
allocate(mld_d_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
!!$ write(0,*) 'Check 4: ',allocated(p%precv(1)%sm)
allocate(mld_d_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_d_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
allocate(mld_d_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
end do
ilev_ = nlev_
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_d_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_coarse_solve_) = mld_bjac_
#if defined(HAVE_UMF_)
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_umf_
#elif defined(HAVE_SLU_)
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_slu_
#if defined(HAVE_UMF_)
allocate(mld_d_umf_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
#elif defined(HAVE_SLU_)
allocate(mld_d_slu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
#else
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
allocate(mld_d_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
#endif
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 4
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 4
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 4
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
!!$ write(0,*) 'Check 5: ',allocated(p%precv(1)%sm)
call p%precv(ilev_)%default()
p%precv(ilev_)%parms%coarse_solve = mld_bjac_
call p%precv(ilev_)%set(mld_smoother_sweeps_,4,info)
call p%precv(ilev_)%set(mld_sub_restr_,psb_none_,info)
call p%precv(ilev_)%set(mld_sub_prol_,psb_none_,info)
call p%precv(ilev_)%set(mld_sub_ovr_,0,info)
case default
write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"'
info = psb_err_pivot_too_small_
mlprec/mld_dprecset.F90
+375 -677
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_dslu_bld.f90
+1 -1
View File
@@ -72,7 +72,7 @@
subroutine mld_dslu_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dslu_bld
use mld_d_inner_mod, mld_protect_name => mld_dslu_bld
implicit none
mlprec/mld_dslu_interface.c
+90 -161
View File
@@ -116,50 +116,10 @@ typedef struct {
#endif
#ifdef LowerUnderscore
#define mld_dslu_fact_ mld_dslu_fact_
#define mld_dslu_solve_ mld_dslu_solve_
#define mld_dslu_free_ mld_dslu_free_
#endif
#ifdef LowerDoubleUnderscore
#define mld_dslu_fact_ mld_dslu_fact__
#define mld_dslu_solve_ mld_dslu_solve__
#define mld_dslu_free_ mld_dslu_free__
#endif
#ifdef LowerCase
#define mld_dslu_fact_ mld_dslu_fact
#define mld_dslu_solve_ mld_dslu_solve
#define mld_dslu_free_ mld_dslu_free
#endif
#ifdef UpperUnderscore
#define mld_dslu_fact_ MLD_DSLU_FACT_
#define mld_dslu_solve_ MLD_DSLU_SOLVE_
#define mld_dslu_free_ MLD_DSLU_FREE_
#endif
#ifdef UpperDoubleUnderscore
#define mld_dslu_fact_ MLD_DSLU_FACT__
#define mld_dslu_solve_ MLD_DSLU_SOLVE__
#define mld_dslu_free_ MLD_DSLU_FREE__
#endif
#ifdef UpperCase
#define mld_dslu_fact_ MLD_DSLU_FACT
#define mld_dslu_solve_ MLD_DSLU_SOLVE
#define mld_dslu_free_ MLD_DSLU_FREE
#endif
void
mld_dslu_fact_(int *n, int *nnz,
double *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)
int
mld_dslu_fact(int n, int nnz, double *values,
int *rowptr, int *colind, void **f_factors)
{
/*
@@ -187,6 +147,7 @@ mld_dslu_fact_(int *n, int *nnz,
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
int info;
trans = NOTRANS;
@@ -197,17 +158,13 @@ mld_dslu_fact_(int *n, int *nnz,
/* 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];
dCreate_CompRow_Matrix(&A, *n, *n, *nnz, values, colind, rowptr,
dCreate_CompRow_Matrix(&A, n, n, nnz, values, colind, rowptr,
SLU_NR, SLU_D, 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[].");
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:
@@ -226,9 +183,9 @@ mld_dslu_fact_(int *n, int *nnz,
relax = sp_ienv(2);
dgstrf(&options, &AC, drop_tol, relax, panel_size,
etree, NULL, 0, perm_c, perm_r, L, U, &stat, info);
etree, NULL, 0, perm_c, perm_r, L, U, &stat, &info);
if ( *info == 0 ) {
if ( info == 0 ) {
Lstore = (SCformat *) L->Store;
Ustore = (NCformat *) U->Store;
dQuerySpace(L, U, &mem_usage);
@@ -241,8 +198,8 @@ mld_dslu_fact_(int *n, int *nnz,
mem_usage.expansions);
#endif
} else {
printf("dgstrf() error returns INFO= %d\n", *info);
if ( *info <= *n ) { /* factorization completes */
printf("dgstrf() error returns INFO= %d\n", info);
if ( info <= n ) { /* factorization completes */
dQuerySpace(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,
@@ -250,130 +207,101 @@ mld_dslu_fact_(int *n, int *nnz,
}
}
/* 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;
*f_factors = (void *) LUfactors;
/* Free un-wanted storage */
SUPERLU_FREE(etree);
Destroy_SuperMatrix_Store(&A);
Destroy_CompCol_Permuted(&AC);
StatFree(&stat);
return(info);
#else
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
*info=-1;
return(-1);
#endif
}
void
mld_dslu_solve_(int *itrans, int *n, int *nrhs,
double *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)
int
mld_dslu_solve(int itrans, int n, int nrhs, double *b, int ldb,
void *f_factors)
{
/*
* This routine can be called from Fortran.
* performs triangular solve
*
*/
/*
* This routine can be called from Fortran.
* performs triangular solve
*
*/
int info;
#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;
double 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;
dCreate_Dense_Matrix(&B, *n, *nrhs, b, *ldb, SLU_DN, SLU_D, SLU_GE);
/* Solve the system A*X=B, overwriting B with X. */
dgstrs (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_dslu_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;
double drop_tol = 0.0;
mem_usage_t mem_usage;
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
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;
double drop_tol = 0.0;
SuperLUStat_t stat;
factors_t *LUfactors;
if (itrans == 0) {
trans = NOTRANS;
/* Free the LU factors in the factors handle */
LUfactors = (factors_t*) *f_factors;
} 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;
dCreate_Dense_Matrix(&B, n, nrhs, b, ldb, SLU_DN, SLU_D, SLU_GE);
/* Solve the system A*X=B, overwriting B with X. */
dgstrs (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
return(info);
}
int
mld_dslu_free(void *f_factors)
{
/*
* This routine can be called from Fortran.
*
* free all storage in the end
*
*/
#ifdef Have_SLU_
factors_t *LUfactors;
/* Free the LU factors in the factors handle */
LUfactors = (factors_t*) f_factors;
if (LUfactors != NULL) {
SUPERLU_FREE (LUfactors->perm_r);
SUPERLU_FREE (LUfactors->perm_c);
Destroy_SuperNode_Matrix(LUfactors->L);
@@ -381,10 +309,11 @@ mld_dslu_free_(
SUPERLU_FREE (LUfactors->L);
SUPERLU_FREE (LUfactors->U);
SUPERLU_FREE (LUfactors);
*info = 0;
}
return(0);
#else
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
*info=-1;
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
return(-1);
#endif
}
mlprec/mld_dslud_bld.f90
+3 -2
View File
@@ -63,13 +63,13 @@
! 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.
! info - integer, output.
! Error code.
!
subroutine mld_dsludist_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dsludist_bld
use mld_d_inner_mod, mld_protect_name => mld_dsludist_bld
implicit none
@@ -128,6 +128,7 @@ subroutine mld_dsludist_bld(a,desc_a,p,info)
call mld_dsludist_fact(mglob,nrow,nzt,ifrst,&
& aa%val,aa%irp,aa%ja,p%iprcparm(mld_slud_ptr_),&
& npr, npc, info)
if (info /= psb_success_) then
ch_err='psb_sludist_fact'
call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
mlprec/mld_dslud_interface.c
+20 -66
View File
@@ -115,51 +115,11 @@ typedef struct {
#endif
#ifdef LowerUnderscore
#define mld_dsludist_fact_ mld_dsludist_fact_
#define mld_dsludist_solve_ mld_dsludist_solve_
#define mld_dsludist_free_ mld_dsludist_free_
#endif
#ifdef LowerDoubleUnderscore
#define mld_dsludist_fact_ mld_dsludist_fact__
#define mld_dsludist_solve_ mld_dsludist_solve__
#define mld_dsludist_free_ mld_dsludist_free__
#endif
#ifdef LowerCase
#define mld_dsludist_fact_ mld_dsludist_fact
#define mld_dsludist_solve_ mld_dsludist_solve
#define mld_dsludist_free_ mld_dsludist_free
#endif
#ifdef UpperUnderscore
#define mld_dsludist_fact_ MLD_DSLUDIST_FACT_
#define mld_dsludist_solve_ MLD_DSLUDIST_SOLVE_
#define mld_dsludist_free_ MLD_DSLUDIST_FREE_
#endif
#ifdef UpperDoubleUnderscore
#define mld_dsludist_fact_ MLD_DSLUDIST_FACT__
#define mld_dsludist_solve_ MLD_DSLUDIST_SOLVE__
#define mld_dsludist_free_ MLD_DSLUDIST_FREE__
#endif
#ifdef UpperCase
#define mld_dsludist_fact_ MLD_DSLUDIST_FACT
#define mld_dsludist_solve_ MLD_DSLUDIST_SOLVE
#define mld_dsludist_free_ MLD_DSLUDIST_FREE
#endif
void
mld_dsludist_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)
int
mld_dsludist_fact(int n, int nl, int nnzl, int ffstr,
double *values, int *rowptr, int *colind,
void **f_factors, int nprow, int npcol)
{
/*
* This routine can be called from Fortran.
@@ -179,7 +139,7 @@ mld_dsludist_fact_(int *n, int *nl, int *nnzl, int *ffstr,
LUstruct_t *LUstruct;
SOLVEstruct_t SOLVEstruct;
gridinfo_t *grid;
int i, panel_size, permc_spec, relax;
int i, panel_size, permc_spec, relax, info;
trans_t trans;
double drop_tol = 0.0,b[1],berr[1];
mem_usage_t mem_usage;
@@ -193,42 +153,35 @@ mld_dsludist_fact_(int *n, int *nl, int *nnzl, int *ffstr,
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);
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;
fst_row = (ffstr) -1;
A = (SuperMatrix *) malloc(sizeof(SuperMatrix));
dCreate_CompRowLoc_Matrix_dist(A, *n, *n, *nnzl, *nl, fst_row,
ival, icol, irpt,
dCreate_CompRowLoc_Matrix_dist(A, n, n, nnzl, nl, fst_row,
values, colind, rowptr,
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);
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);
pdgssvx(&options, A, ScalePermstruct, b, nl, 0,
grid, LUstruct, &SOLVEstruct, berr, &stat, &info);
if ( *info == 0 ) {
if ( info == 0 ) {
;
} else {
printf("pdgssvx() error returns INFO= %d\n", *info);
if ( *info <= *n ) { /* factorization completes */
printf("pdgssvx() error returns INFO= %d\n", info);
if ( info <= n ) { /* factorization completes */
;
}
}
@@ -247,12 +200,13 @@ mld_dsludist_fact_(int *n, int *nl, int *nnzl, int *ffstr,
/* 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;
*f_factors = (void *) LUfactors;
PStatFree(&stat);
return(info);
#else
fprintf(stderr," SLUDist Not Configured, fix make.inc and recompile\n");
*info=-1;
return(-1);
#endif
}
mlprec/mld_dsp_renum.f90
+1 -1
View File
@@ -84,7 +84,7 @@
subroutine mld_dsp_renum(a,blck,p,atmp,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dsp_renum
use mld_d_inner_mod, mld_protect_name => mld_dsp_renum
implicit none
mlprec/mld_dumf_interface.c
+2 -2
View File
@@ -188,8 +188,8 @@ int mld_dumf_free(void *symptr, void *numptr)
Symbolic = symptr;
Numeric = numptr;
umfpack_di_free_numeric(&Numeric);
umfpack_di_free_symbolic(&Symbolic);
if (numptr != NULL) umfpack_di_free_numeric(&Numeric);
if (symptr != NULL) umfpack_di_free_symbolic(&Symbolic);
return 0;
#else
fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n");
mlprec/mld_inner_mod.f90
-962
View File
@@ -1,962 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_inner_mod.f90
!
! Module: mld_inner_mod
!
! This module defines the interfaces to the real/complex, single/double
! precision versions of the MLD2P4 routines, except those of the user level,
! whose interfaces are defined in mld_prec_mod.f90.
!
module mld_inner_mod
use mld_prec_type
use mld_move_alloc_mod
interface mld_baseprec_aply
subroutine mld_sbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprec_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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprec_type), intent(in) :: prec
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1) :: trans
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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprec_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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprec_type), intent(in) :: prec
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1) :: trans
complex(psb_dpk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_zbaseprec_aply
end interface
interface mld_mlprec_bld
subroutine mld_smlprec_bld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_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), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_smlprec_bld
subroutine mld_dmlprec_bld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
implicit none
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dprec_type), intent(inout), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_dmlprec_bld
subroutine mld_cmlprec_bld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_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), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_cmlprec_bld
subroutine mld_zmlprec_bld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
implicit none
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_zprec_type), intent(inout) :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_zmlprec_bld
end interface
interface mld_as_aply
subroutine mld_sas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprec_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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprec_type), intent(in) :: prec
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1) :: trans
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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprec_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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprec_type), intent(in) :: prec
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1) :: trans
complex(psb_dpk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_zas_aply
end interface
interface mld_mlprec_aply
subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type, mld_sprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_sprec_type), intent(in) :: p
real(psb_spk_),intent(in) :: alpha,beta
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
character,intent(in) :: trans
real(psb_spk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_smlprec_aply
subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type, mld_dprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_dprec_type), intent(in) :: p
real(psb_dpk_),intent(in) :: alpha,beta
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
character,intent(in) :: trans
real(psb_dpk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_dmlprec_aply
subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type, mld_cprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_cprec_type), intent(in) :: p
complex(psb_spk_),intent(in) :: alpha,beta
complex(psb_spk_),intent(in) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
character,intent(in) :: trans
complex(psb_spk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_cmlprec_aply
subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type, mld_zprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_zprec_type), intent(in) :: p
complex(psb_dpk_),intent(in) :: alpha,beta
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
character,intent(in) :: trans
complex(psb_dpk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_zmlprec_aply
end interface
interface mld_asmat_bld
Subroutine mld_sasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
integer, intent(in) :: ptype,novr
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_dspmat_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_dasmat_bld
Subroutine mld_casmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
integer, intent(in) :: ptype,novr
Type(psb_zspmat_type), Intent(in) :: a
Type(psb_zspmat_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_zasmat_bld
end interface
interface mld_sp_renum
subroutine mld_ssp_renum(a,blck,p,atmp,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_sspmat_type), intent(in) :: a,blck
type(psb_sspmat_type), intent(out) :: atmp
type(mld_sbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_ssp_renum
subroutine mld_dsp_renum(a,blck,p,atmp,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_dspmat_type), intent(in) :: a,blck
type(psb_dspmat_type), intent(out) :: atmp
type(mld_dbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_dsp_renum
subroutine mld_csp_renum(a,blck,p,atmp,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_cspmat_type), intent(in) :: a,blck
type(psb_cspmat_type), intent(out) :: atmp
type(mld_cbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_csp_renum
subroutine mld_zsp_renum(a,blck,p,atmp,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_zspmat_type), intent(in) :: a,blck
type(psb_zspmat_type), intent(out) :: atmp
type(mld_zbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_zsp_renum
end interface
interface mld_coarse_bld
subroutine mld_scoarse_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type, mld_sonelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_scoarse_bld
subroutine mld_dcoarse_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type, mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_dcoarse_bld
subroutine mld_ccoarse_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type, mld_conelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_conelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_ccoarse_bld
subroutine mld_zcoarse_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type, mld_zonelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_zonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zcoarse_bld
end interface
interface mld_aggrmap_bld
subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
integer, intent(in) :: aggr_type
real(psb_spk_), intent(in) :: theta
type(psb_sspmat_type), intent(in) :: 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,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
integer, intent(in) :: aggr_type
real(psb_dpk_), intent(in) :: theta
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
end subroutine mld_daggrmap_bld
subroutine mld_caggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
integer, intent(in) :: aggr_type
real(psb_spk_), intent(in) :: theta
type(psb_cspmat_type), intent(in) :: 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,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
integer, intent(in) :: aggr_type
real(psb_dpk_), intent(in) :: theta
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
end subroutine mld_zaggrmap_bld
end interface
interface mld_aggrmat_asb
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type, mld_sonelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_asb
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type, mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_asb
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type, mld_conelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_conelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_asb
subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type, mld_zonelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_zonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_asb
end interface
interface mld_aggrmat_nosmth_asb
subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type, mld_sonelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_nosmth_asb
subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type, mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_nosmth_asb
subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type, mld_conelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_conelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_nosmth_asb
subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type, mld_zonelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_zonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_nosmth_asb
end interface
interface mld_aggrmat_smth_asb
subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type, mld_sonelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_smth_asb
subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type, mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_smth_asb
subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type, mld_conelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_conelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_smth_asb
subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type, mld_zonelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_zonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_smth_asb
end interface
interface mld_aggrmat_minnrg_asb
subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type, mld_donelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_donelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_minnrg_asb
end interface
interface mld_baseprec_bld
subroutine mld_sbaseprec_bld(a,desc_a,p,info,upd)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_sspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_sbaseprec_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
end subroutine mld_sbaseprec_bld
subroutine mld_dbaseprec_bld(a,desc_a,p,info,upd)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_dspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dbaseprec_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
end subroutine mld_dbaseprec_bld
subroutine mld_cbaseprec_bld(a,desc_a,p,info,upd)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_cspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_cbaseprec_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
end subroutine mld_cbaseprec_bld
subroutine mld_zbaseprec_bld(a,desc_a,p,info,upd)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_zspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_zbaseprec_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
end subroutine mld_zbaseprec_bld
end interface
interface mld_as_bld
subroutine mld_sas_bld(a,desc_a,p,upd,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_sspmat_type),intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_sbaseprec_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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_dspmat_type),intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dbaseprec_type),intent(inout) :: p
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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_cspmat_type),intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_cbaseprec_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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_zspmat_type),intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_zbaseprec_type),intent(inout) :: p
character, intent(in) :: upd
integer, intent(out) :: info
end subroutine mld_zas_bld
end interface
interface mld_diag_bld
subroutine mld_sdiag_bld(a,desc_data,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprec_type), intent(inout) :: p
end subroutine mld_sdiag_bld
subroutine mld_ddiag_bld(a,desc_data,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprec_type), intent(inout) :: p
end subroutine mld_ddiag_bld
subroutine mld_cdiag_bld(a,desc_data,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
integer, intent(out) :: info
type(psb_cspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprec_type), intent(inout) :: p
end subroutine mld_cdiag_bld
subroutine mld_zdiag_bld(a,desc_data,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
integer, intent(out) :: info
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprec_type), intent(inout) :: p
end subroutine mld_zdiag_bld
end interface
interface mld_fact_bld
subroutine mld_sfact_bld(a,p,upd,info,blck)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_sspmat_type), intent(in), target :: a
type(mld_sbaseprec_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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_dspmat_type), intent(in), target :: a
type(mld_dbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_cspmat_type), intent(in), target :: a
type(mld_cbaseprec_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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_zspmat_type), intent(in), target :: a
type(mld_zbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
character, intent(in) :: upd
type(psb_zspmat_type), intent(in), target, optional :: blck
end subroutine mld_zfact_bld
end interface
interface mld_ilu_bld
subroutine mld_silu_bld(a,p,upd,info,blck)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target :: a
type(mld_sbaseprec_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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(mld_dbaseprec_type), intent(inout) :: p
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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
integer, intent(out) :: info
type(psb_cspmat_type), intent(in), target :: a
type(mld_cbaseprec_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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
integer, intent(out) :: info
type(psb_zspmat_type), intent(in), target :: a
type(mld_zbaseprec_type), intent(inout) :: p
character, intent(in) :: upd
type(psb_zspmat_type), intent(in), optional :: blck
end subroutine mld_zilu_bld
end interface
interface mld_sludist_bld
subroutine mld_ssludist_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_sbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_ssludist_bld
subroutine mld_dsludist_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_dbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_dsludist_bld
subroutine mld_csludist_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_cspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_cbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_csludist_bld
subroutine mld_zsludist_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_zspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_zbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_zsludist_bld
end interface
interface mld_slu_bld
subroutine mld_sslu_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_sbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_sslu_bld
subroutine mld_dslu_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_dbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_dslu_bld
subroutine mld_cslu_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_cspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_cbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_cslu_bld
subroutine mld_zslu_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_zspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_zbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_zslu_bld
end interface
interface mld_umf_bld
subroutine mld_sumf_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprec_type
type(psb_sspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_sbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_sumf_bld
subroutine mld_dumf_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprec_type
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_dbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_dumf_bld
subroutine mld_cumf_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprec_type
type(psb_cspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_cbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_cumf_bld
subroutine mld_zumf_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprec_type
type(psb_zspmat_type), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_zbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
end subroutine mld_zumf_bld
end interface
!!$ interface mld_ilu0_fact
!!$ subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck,upd)
!!$ use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
!!$ 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
!!$ character, intent(in), optional :: upd
!!$ real(psb_spk_), intent(inout) :: d(:)
!!$ end subroutine mld_silu0_fact
!!$ subroutine mld_dilu0_fact(ialg,a,l,u,d,info,blck,upd)
!!$ use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
!!$ integer, intent(in) :: ialg
!!$ integer, intent(out) :: info
!!$ type(psb_dspmat_type),intent(in) :: a
!!$ type(psb_dspmat_type),intent(inout) :: l,u
!!$ type(psb_dspmat_type),intent(in), optional, target :: blck
!!$ character, intent(in), optional :: upd
!!$ real(psb_dpk_), intent(inout) :: d(:)
!!$ end subroutine mld_dilu0_fact
!!$ subroutine mld_cilu0_fact(ialg,a,l,u,d,info,blck,upd)
!!$ use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
!!$ 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
!!$ character, intent(in), optional :: upd
!!$ complex(psb_spk_), intent(inout) :: d(:)
!!$ end subroutine mld_cilu0_fact
!!$ subroutine mld_zilu0_fact(ialg,a,l,u,d,info,blck,upd)
!!$ use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
!!$ integer, intent(in) :: ialg
!!$ integer, intent(out) :: info
!!$ type(psb_zspmat_type),intent(in) :: a
!!$ type(psb_zspmat_type),intent(inout) :: l,u
!!$ type(psb_zspmat_type),intent(in), optional, target :: blck
!!$ character, intent(in), optional :: upd
!!$ complex(psb_dpk_), intent(inout) :: d(:)
!!$ end subroutine mld_zilu0_fact
!!$ end interface
!!$
!!$ interface mld_iluk_fact
!!$ subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck)
!!$ use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
!!$ 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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
!!$ integer, intent(in) :: fill_in,ialg
!!$ integer, intent(out) :: info
!!$ type(psb_dspmat_type),intent(in) :: a
!!$ type(psb_dspmat_type),intent(inout) :: l,u
!!$ 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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
!!$ 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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
!!$ integer, intent(in) :: fill_in,ialg
!!$ integer, intent(out) :: info
!!$ type(psb_zspmat_type),intent(in) :: a
!!$ type(psb_zspmat_type),intent(inout) :: l,u
!!$ type(psb_zspmat_type),intent(in), optional, target :: blck
!!$ complex(psb_dpk_), intent(inout) :: d(:)
!!$ end subroutine mld_ziluk_fact
!!$ end interface
!!$
!!$ interface mld_ilut_fact
!!$ subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck)
!!$ use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
!!$ 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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
!!$ integer, intent(in) :: fill_in
!!$ real(psb_dpk_), intent(in) :: thres
!!$ integer, intent(out) :: info
!!$ type(psb_dspmat_type),intent(in) :: a
!!$ type(psb_dspmat_type),intent(inout) :: l,u
!!$ 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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
!!$ 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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
!!$ integer, intent(in) :: fill_in
!!$ real(psb_dpk_), intent(in) :: thres
!!$ integer, intent(out) :: info
!!$ type(psb_zspmat_type),intent(in) :: a
!!$ type(psb_zspmat_type),intent(inout) :: l,u
!!$ type(psb_zspmat_type),intent(in), optional, target :: blck
!!$ complex(psb_dpk_), intent(inout) :: d(:)
!!$ end subroutine mld_zilut_fact
!!$ end interface
end module mld_inner_mod
mlprec/mld_move_alloc_mod.f90
-342
View File
@@ -1,342 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_move_alloc_mod.f90
!
! Module: mld_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_move_alloc_mod
use mld_prec_type
interface mld_move_alloc
module procedure mld_sbaseprec_move_alloc, mld_sonelev_prec_move_alloc,&
& mld_sprec_move_alloc,&
& mld_dbaseprec_move_alloc, mld_donelev_prec_move_alloc,&
& mld_dprec_move_alloc,&
& mld_cbaseprec_move_alloc, mld_conelev_prec_move_alloc,&
& mld_cprec_move_alloc,&
& mld_zbaseprec_move_alloc, mld_zonelev_prec_move_alloc,&
& mld_zprec_move_alloc
end interface
contains
subroutine mld_sbaseprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_sbaseprec_type), intent(inout) :: a, b
integer, intent(out) :: info
integer :: i, isz
call mld_precfree(b,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%desc_data,b%desc_data,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%perm,b%perm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%invperm,b%invperm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%d,b%d,info)
!!$ call move_alloc(a%av,b%av)
if (info /= psb_success_) then
write(0,*) 'Error in baseprec_:transfer',info
end if
end subroutine mld_sbaseprec_move_alloc
subroutine mld_sonelev_prec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_sonelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call mld_precfree(b,info)
if (info == psb_success_) call mld_move_alloc(a%prec,b%prec,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%mlia,b%mlia,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%nlaggr,b%nlaggr,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_sonelev_prec_move_alloc
subroutine mld_sprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_sprec_type), intent(inout) :: a
type(mld_sprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i,isz
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, isz
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_sprec_move_alloc
subroutine mld_dbaseprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_dbaseprec_type), intent(inout) :: a, b
integer, intent(out) :: info
integer :: i, isz
call mld_precfree(b,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%desc_data,b%desc_data,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%perm,b%perm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%invperm,b%invperm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%d,b%d,info)
!!$ call move_alloc(a%av,b%av)
if (info /= psb_success_) then
write(0,*) 'Error in baseprec_:transfer',info
end if
end subroutine mld_dbaseprec_move_alloc
subroutine mld_donelev_prec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_donelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call mld_precfree(b,info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call mld_move_alloc(a%prec,b%prec,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%mlia,b%mlia,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%nlaggr,b%nlaggr,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_donelev_prec_move_alloc
subroutine mld_dprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_dprec_type), intent(inout) :: a
type(mld_dprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i,isz
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, isz
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_dprec_move_alloc
subroutine mld_cbaseprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_cbaseprec_type), intent(inout) :: a, b
integer, intent(out) :: info
integer :: i, isz
call mld_precfree(b,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%desc_data,b%desc_data,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%perm,b%perm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%invperm,b%invperm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%d,b%d,info)
!!$ call move_alloc(a%av,b%av)
if (info /= psb_success_) then
write(0,*) 'Error in baseprec_:transfer',info
end if
end subroutine mld_cbaseprec_move_alloc
subroutine mld_conelev_prec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_conelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call mld_precfree(b,info)
if (info == psb_success_) call mld_move_alloc(a%prec,b%prec,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%mlia,b%mlia,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%nlaggr,b%nlaggr,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_conelev_prec_move_alloc
subroutine mld_cprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_cprec_type), intent(inout) :: a
type(mld_cprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i,isz
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, isz
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_cprec_move_alloc
subroutine mld_zbaseprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_zbaseprec_type), intent(inout) :: a, b
integer, intent(out) :: info
integer :: i, isz
call mld_precfree(b,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%desc_data,b%desc_data,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%perm,b%perm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%invperm,b%invperm,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%d,b%d,info)
!!$ call move_alloc(a%av,b%av)
if (info /= psb_success_) then
write(0,*) 'Error in baseprec_:transfer',info
end if
end subroutine mld_zbaseprec_move_alloc
subroutine mld_zonelev_prec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_zonelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call mld_precfree(b,info)
if (info == psb_success_) call mld_move_alloc(a%prec,b%prec,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%mlia,b%mlia,info)
!!$ if (info == psb_success_) call psb_move_alloc(a%nlaggr,b%nlaggr,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_zonelev_prec_move_alloc
subroutine mld_zprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_zprec_type), intent(inout) :: a
type(mld_zprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i,isz
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, isz
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_zprec_move_alloc
end module mld_move_alloc_mod
mlprec/mld_prec_mod.f90
+4 -452
View File
@@ -45,457 +45,9 @@
!
module mld_prec_mod
use mld_prec_type
interface mld_precinit
subroutine mld_sprecinit(p,ptype,info,nlev)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_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_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
character(len=*), intent(in) :: ptype
integer, intent(out) :: info
integer, optional, intent(in) :: nlev
end subroutine mld_dprecinit
subroutine mld_cprecinit(p,ptype,info,nlev)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
type(mld_zprec_type), intent(inout) :: p
character(len=*), intent(in) :: ptype
integer, intent(out) :: info
integer, optional, intent(in) :: nlev
end subroutine mld_zprecinit
end interface
interface mld_precset
module procedure mld_i_sprecseti, mld_i_sprecsetc, mld_i_sprecsetr,&
& mld_i_dprecseti, mld_i_dprecsetc, mld_i_dprecsetr,&
& mld_i_cprecseti, mld_i_cprecsetc, mld_i_cprecsetr,&
& mld_i_zprecseti, mld_i_zprecsetc, mld_i_zprecsetr
end interface
interface mld_inner_precset
subroutine mld_sprecsetsm(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_type, mld_s_base_smoother_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
class(mld_s_base_smoother_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_sprecsetsm
subroutine mld_sprecsetsv(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_type, mld_s_base_solver_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
class(mld_s_base_solver_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_sprecsetsv
subroutine mld_sprecseti(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_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_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_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_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_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_dprecsetsm(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type, mld_d_base_smoother_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
class(mld_d_base_smoother_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_dprecsetsm
subroutine mld_dprecsetsv(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type, mld_d_base_solver_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
class(mld_d_base_solver_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_dprecsetsv
subroutine mld_dprecseti(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_dprecseti
subroutine mld_dprecsetr(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_dprecsetr
subroutine mld_dprecsetc(p,what,string,info,ilev)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
type(mld_dprec_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_dprecsetc
subroutine mld_cprecseti(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_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_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_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_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
type(mld_zprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_zprecseti
subroutine mld_zprecsetr(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
type(mld_zprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_zprecsetr
subroutine mld_zprecsetc(p,what,string,info,ilev)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
type(mld_zprec_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_zprecsetc
end interface
!!$
!!$ interface mld_precaply
!!$ subroutine mld_sprecaply(prec,x,y,desc_data,info,trans,work)
!!$ use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
!!$ use mld_prec_type, only : mld_sprec_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_sprecaply
!!$ subroutine mld_sprecaply1(prec,x,desc_data,info,trans)
!!$ use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
!!$ use mld_prec_type, only : mld_sprec_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_sprecaply1
!!$ subroutine mld_dprecaply(prec,x,y,desc_data,info,trans,work)
!!$ use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
!!$ use mld_prec_type, only : mld_dprec_type
!!$ type(psb_desc_type),intent(in) :: desc_data
!!$ type(mld_dprec_type), intent(in) :: prec
!!$ real(psb_dpk_),intent(in) :: x(:)
!!$ real(psb_dpk_),intent(inout) :: y(:)
!!$ integer, intent(out) :: info
!!$ character(len=1), optional :: trans
!!$ real(psb_dpk_),intent(inout), optional, target :: work(:)
!!$ end subroutine mld_dprecaply
!!$ subroutine mld_dprecaply1(prec,x,desc_data,info,trans)
!!$ use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
!!$ use mld_prec_type, only : mld_dprec_type
!!$ type(psb_desc_type),intent(in) :: desc_data
!!$ type(mld_dprec_type), intent(in) :: prec
!!$ real(psb_dpk_),intent(inout) :: x(:)
!!$ integer, intent(out) :: info
!!$ character(len=1), optional :: trans
!!$ end subroutine mld_dprecaply1
!!$ subroutine mld_cprecaply(prec,x,y,desc_data,info,trans,work)
!!$ use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
!!$ use mld_prec_type, only : mld_cprec_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_cprecaply
!!$ subroutine mld_cprecaply1(prec,x,desc_data,info,trans)
!!$ use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
!!$ use mld_prec_type, only : mld_cprec_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_cprecaply1
!!$ subroutine mld_zprecaply(prec,x,y,desc_data,info,trans,work)
!!$ use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
!!$ use mld_prec_type, only : mld_zprec_type
!!$ type(psb_desc_type),intent(in) :: desc_data
!!$ type(mld_zprec_type), intent(in) :: prec
!!$ complex(psb_dpk_),intent(in) :: x(:)
!!$ complex(psb_dpk_),intent(inout) :: y(:)
!!$ integer, intent(out) :: info
!!$ character(len=1), optional :: trans
!!$ complex(psb_dpk_),intent(inout), optional, target :: work(:)
!!$ end subroutine mld_zprecaply
!!$ subroutine mld_zprecaply1(prec,x,desc_data,info,trans)
!!$ use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
!!$ use mld_prec_type, only : mld_zprec_type
!!$ type(psb_desc_type),intent(in) :: desc_data
!!$ type(mld_zprec_type), intent(in) :: prec
!!$ complex(psb_dpk_),intent(inout) :: x(:)
!!$ integer, intent(out) :: info
!!$ character(len=1), optional :: trans
!!$ end subroutine mld_zprecaply1
!!$ end interface
!!$
interface mld_precbld
subroutine mld_sprecbld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_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), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_sprecbld
subroutine mld_dprecbld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
implicit none
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dprec_type), intent(inout), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_dprecbld
subroutine mld_cprecbld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_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), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_cprecbld
subroutine mld_zprecbld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
implicit none
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_zprec_type), intent(inout) :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_zprecbld
end interface
contains
subroutine mld_i_sprecseti(p,what,val,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_sprecseti
subroutine mld_i_sprecsetr(p,what,val,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_sprecsetr
subroutine mld_i_sprecsetc(p,what,val,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sprec_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_sprecsetc
subroutine mld_i_dprecseti(p,what,val,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_dprecseti
subroutine mld_i_dprecsetr(p,what,val,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_dprecsetr
subroutine mld_i_dprecsetc(p,what,val,info)
use psb_sparse_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dprec_type
type(mld_dprec_type), intent(inout) :: p
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_dprecsetc
subroutine mld_i_cprecseti(p,what,val,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_type
type(mld_cprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_cprecseti
subroutine mld_i_cprecsetr(p,what,val,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_type
type(mld_cprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_cprecsetr
subroutine mld_i_cprecsetc(p,what,val,info)
use psb_sparse_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cprec_type
type(mld_cprec_type), intent(inout) :: p
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_cprecsetc
subroutine mld_i_zprecseti(p,what,val,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
type(mld_zprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_zprecseti
subroutine mld_i_zprecsetr(p,what,val,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
type(mld_zprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_zprecsetr
subroutine mld_i_zprecsetc(p,what,val,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zprec_type
type(mld_zprec_type), intent(inout) :: p
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_zprecsetc
use mld_s_prec_mod
use mld_d_prec_mod
use mld_c_prec_mod
use mld_z_prec_mod
end module mld_prec_mod
mlprec/mld_s_as_smoother.f90
+131 -10
View File
@@ -52,9 +52,11 @@ module mld_s_as_smoother
! class(mld_s_base_solver_type), allocatable :: sv
!
type(psb_sspmat_type) :: nd
type(psb_desc_type) :: desc_data
integer :: novr, restr, prol
type(psb_desc_type) :: desc_data
integer :: novr, restr, prol, nd_nnz_tot
contains
procedure, pass(sm) :: check => s_as_smoother_check
procedure, pass(sm) :: dump => s_as_smoother_dmp
procedure, pass(sm) :: build => s_as_smoother_bld
procedure, pass(sm) :: apply => s_as_smoother_apply
procedure, pass(sm) :: free => s_as_smoother_free
@@ -63,13 +65,16 @@ module mld_s_as_smoother
procedure, pass(sm) :: setr => s_as_smoother_setr
procedure, pass(sm) :: descr => s_as_smoother_descr
procedure, pass(sm) :: sizeof => s_as_smoother_sizeof
procedure, pass(sm) :: default => s_as_smoother_default
end type mld_s_as_smoother_type
private :: s_as_smoother_bld, s_as_smoother_apply, &
& s_as_smoother_free, s_as_smoother_seti, &
& s_as_smoother_setc, s_as_smoother_setr,&
& s_as_smoother_descr, s_as_smoother_sizeof
& s_as_smoother_descr, s_as_smoother_sizeof, &
& s_as_smoother_check, s_as_smoother_default,&
& s_as_smoother_dmp
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
@@ -79,6 +84,73 @@ module mld_s_as_smoother
contains
subroutine s_as_smoother_default(sm)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_as_smoother_type), intent(inout) :: sm
sm%restr = psb_halo_
sm%prol = psb_none_
sm%novr = 1
if (allocated(sm%sv)) then
call sm%sv%default()
end if
return
end subroutine s_as_smoother_default
subroutine s_as_smoother_check(sm,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_as_smoother_type), intent(inout) :: sm
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_as_smoother_check'
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(sm%restr,&
& 'Restrictor',psb_halo_,is_legal_restrict)
call mld_check_def(sm%prol,&
& 'Prolongator',psb_none_,is_legal_prolong)
call mld_check_def(sm%novr,&
& 'Overlap layers ',0,is_legal_n_ovr)
if (allocated(sm%sv)) then
call sm%sv%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_as_smoother_check
subroutine s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
@@ -100,6 +172,8 @@ contains
call psb_erractionsave(err_act)
info = psb_success_
ictxt = psb_cd_get_context(desc_data)
call psb_info (ictxt,me,np)
trans_ = psb_toupper(trans)
select case(trans_)
@@ -250,11 +324,11 @@ contains
goto 9999
end select
call sm%sv%apply(sone,tx,szero,ty,sm%desc_data,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in sub_aply Jacobi Sweeps = 1')
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
@@ -401,7 +475,7 @@ contains
! and Y(j) is the approximate solution at sweep j.
!
ww(1:n_row) = tx(1:n_row)
call psb_spmm(-sone,sm%nd,tx,sone,ww,sm%desc_data,info,work=aux,trans=trans_)
call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
@@ -525,7 +599,7 @@ contains
integer, intent(out) :: info
! Local variables
type(psb_sspmat_type) :: blck, atmp
integer :: n_row,n_col, nrow_a, nhalo, novr, data_
integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='s_as_smoother_bld', ch_err
@@ -631,6 +705,10 @@ contains
call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4')
goto 9999
end if
nzeros = sm%nd%get_nzeros()
!!$ write(0,*) me,' ND nzeors ',nzeros
call psb_sum(ictxt,nzeros)
sm%nd_nnz_tot = nzeros
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
@@ -677,9 +755,6 @@ contains
case default
if (allocated(sm%sv)) then
call sm%sv%set(what,val,info)
!!$ else
!!$ write(0,*) trim(name),' Missing component, not setting!'
!!$ info = 1121
end if
end select
@@ -871,4 +946,50 @@ contains
return
end function s_as_smoother_sizeof
subroutine s_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
use psb_sparse_mod
implicit none
class(mld_s_as_smoother_type), intent(in) :: sm
integer, intent(in) :: ictxt,level
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver
integer :: i, j, il1, iln, lname, lev
integer :: icontxt,iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
logical :: smoother_
! len of prefix_
info = 0
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_smth_s"
end if
call psb_info(ictxt,iam,np)
if (present(smoother)) then
smoother_ = smoother
else
smoother_ = .false.
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
lname = lname + 5
if (smoother_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
if (sm%nd%is_asb()) &
& call sm%nd%print(fname,head=head)
end if
! At base level do nothing for the smoother
if (allocated(sm%sv)) &
& call sm%sv%dump(ictxt,level,info,solver=solver)
end subroutine s_as_smoother_dmp
end module mld_s_as_smoother
mlprec/mld_s_id_solver.f90
+280
View File
@@ -0,0 +1,280 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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.
!!$
!!$
!
!
!
! Identity solver. Reference for nullprec.
!
!
module mld_s_id_solver
use mld_s_prec_type
type, extends(mld_s_base_solver_type) :: mld_s_id_solver_type
contains
procedure, pass(sv) :: build => s_id_solver_bld
procedure, pass(sv) :: apply => s_id_solver_apply
procedure, pass(sv) :: free => s_id_solver_free
procedure, pass(sv) :: seti => s_id_solver_seti
procedure, pass(sv) :: setc => s_id_solver_setc
procedure, pass(sv) :: setr => s_id_solver_setr
procedure, pass(sv) :: descr => s_id_solver_descr
procedure, pass(sv) :: sizeof => s_id_solver_sizeof
end type mld_s_id_solver_type
private :: s_id_solver_bld, s_id_solver_apply, &
& s_id_solver_free, s_id_solver_seti, &
& s_id_solver_setc, s_id_solver_setr,&
& s_id_solver_descr, s_id_solver_sizeof
contains
subroutine s_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_id_solver_type), intent(in) :: sv
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
integer :: n_row,n_col
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='s_id_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_id_solver_apply
subroutine s_id_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_id_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
! Local variables
integer :: n_row,n_col, nrow_a, nztota
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='s_id_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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),' start'
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 == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_id_solver_bld
subroutine s_id_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_id_solver_seti'
info = psb_success_
return
end subroutine s_id_solver_seti
subroutine s_id_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='s_id_solver_setc'
info = psb_success_
return
end subroutine s_id_solver_setc
subroutine s_id_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_id_solver_setr'
info = psb_success_
return
end subroutine s_id_solver_setr
subroutine s_id_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_id_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_id_solver_free'
info = psb_success_
return
end subroutine s_id_solver_free
subroutine s_id_solver_descr(sv,info,iout)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_id_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_s_id_solver_descr'
integer :: iout_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' Identity local solver '
return
end subroutine s_id_solver_descr
function s_id_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_s_id_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 0
return
end function s_id_solver_sizeof
end module mld_s_id_solver
mlprec/mld_s_ilu_solver.f90
+134 -15
View File
@@ -1,4 +1,4 @@
!!$
!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
@@ -48,11 +48,12 @@ module mld_s_ilu_solver
use mld_s_prec_type
type, extends(mld_s_base_solver_type) :: mld_s_ilu_solver_type
type(psb_sspmat_type) :: l, u
type(psb_sspmat_type) :: l, u
real(psb_spk_), allocatable :: d(:)
integer :: fact_type, fill_in
real(psb_spk_) :: thresh
contains
procedure, pass(sv) :: dump => s_ilu_solver_dmp
procedure, pass(sv) :: build => s_ilu_solver_bld
procedure, pass(sv) :: apply => s_ilu_solver_apply
procedure, pass(sv) :: free => s_ilu_solver_free
@@ -61,13 +62,15 @@ module mld_s_ilu_solver
procedure, pass(sv) :: setr => s_ilu_solver_setr
procedure, pass(sv) :: descr => s_ilu_solver_descr
procedure, pass(sv) :: sizeof => s_ilu_solver_sizeof
procedure, pass(sv) :: default => s_ilu_solver_default
end type mld_s_ilu_solver_type
private :: s_ilu_solver_bld, s_ilu_solver_apply, &
& s_ilu_solver_free, s_ilu_solver_seti, &
& s_ilu_solver_setc, s_ilu_solver_setr,&
& s_ilu_solver_descr, s_ilu_solver_sizeof
& s_ilu_solver_descr, s_ilu_solver_sizeof, &
& s_ilu_solver_default, s_ilu_solver_dmp
interface mld_ilu0_fact
@@ -109,13 +112,74 @@ module mld_s_ilu_solver
end interface
character(len=15), parameter, private :: &
& fact_names(0:4)=(/'none ','DIAG ?? ',&
& fact_names(0:mld_slv_delta_+4)=(/&
& 'none ','none ',&
& 'none ','none ',&
& 'none ','DIAG ?? ',&
& 'ILU(n) ',&
& 'MILU(n) ','ILU(t,n) '/)
contains
subroutine s_ilu_solver_default(sv)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_ilu_solver_type), intent(inout) :: sv
sv%fact_type = mld_ilu_n_
sv%fill_in = 0
sv%thresh = szero
return
end subroutine s_ilu_solver_default
subroutine s_ilu_solver_check(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_ilu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_ilu_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(sv%fact_type,&
& 'Factorization',mld_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(sv%fill_in,&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(sv%thresh,&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_ilu_solver_check
subroutine s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
@@ -131,7 +195,7 @@ contains
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_ilu_solver_apply'
character(len=20) :: name='s_ilu_solver_apply'
call psb_erractionsave(err_act)
@@ -236,7 +300,7 @@ contains
integer :: n_row,n_col, nrow_a, nztota
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_ilu_solver_bld', ch_err
character(len=20) :: name='s_ilu_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
@@ -291,7 +355,8 @@ contains
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/))
call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/3,sv%fill_in,0,0,0/))
goto 9999
case(0:)
@@ -313,7 +378,8 @@ contains
select case(sv%fill_in)
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/))
call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/3,sv%fill_in,0,0,0/))
goto 9999
case(0)
! Fill-in 0
@@ -343,7 +409,9 @@ contains
case default
! If we end up here, something was wrong up in the call chain.
call psb_errpush(psb_err_alloc_dealloc_,name)
info = psb_err_input_value_invalid_i_
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/3,sv%fact_type,0,0,0/))
goto 9999
end select
@@ -399,7 +467,7 @@ contains
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_seti'
character(len=20) :: name='s_ilu_solver_seti'
info = psb_success_
call psb_erractionsave(err_act)
@@ -438,7 +506,7 @@ contains
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_ilu_solver_setc'
character(len=20) :: name='s_ilu_solver_setc'
info = psb_success_
call psb_erractionsave(err_act)
@@ -476,7 +544,7 @@ contains
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_setr'
character(len=20) :: name='s_ilu_solver_setr'
call psb_erractionsave(err_act)
info = psb_success_
@@ -512,7 +580,7 @@ contains
class(mld_s_ilu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_free'
character(len=20) :: name='s_ilu_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
@@ -595,12 +663,63 @@ contains
integer(psb_long_int_k_) :: val
integer :: i
val = 2*psb_sizeof_int + psb_sizeof_sp
if (allocated(sv%d)) val = val + psb_sizeof_sp * size(sv%d)
val = 2*psb_sizeof_int + psb_sizeof_dp
if (allocated(sv%d)) val = val + psb_sizeof_dp * size(sv%d)
val = val + psb_sizeof(sv%l)
val = val + psb_sizeof(sv%u)
return
end function s_ilu_solver_sizeof
subroutine s_ilu_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
use psb_sparse_mod
implicit none
class(mld_s_ilu_solver_type), intent(in) :: sv
integer, intent(in) :: ictxt,level
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: solver
integer :: i, j, il1, iln, lname, lev
integer :: icontxt,iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
logical :: solver_
! len of prefix_
info = 0
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_slv_d"
end if
call psb_info(ictxt,iam,np)
if (present(solver)) then
solver_ = solver
else
solver_ = .false.
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
lname = lname + 5
if (solver_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_lower.mtx'
if (sv%l%is_asb()) &
& call sv%l%print(fname,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx'
if (allocated(sv%d)) &
& call psb_geprt(fname,sv%d,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_upper.mtx'
if (sv%u%is_asb()) &
& call sv%u%print(fname,head=head)
end if
end subroutine s_ilu_solver_dmp
end module mld_s_ilu_solver
mlprec/mld_s_inner_mod.f90
+141
View File
@@ -0,0 +1,141 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_inner_mod.f90
!
! Module: mld_inner_mod
!
! This module defines the interfaces to the real/complex, single/double
! precision versions of the MLD2P4 routines, except those of the user level,
! whose interfaces are defined in mld_prec_mod.f90.
!
module mld_s_inner_mod
use mld_s_prec_type
use mld_s_move_alloc_mod
interface mld_mlprec_bld
subroutine mld_smlprec_bld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_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), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_smlprec_bld
end interface mld_mlprec_bld
interface mld_mlprec_aply
subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_sprec_type), intent(in) :: p
real(psb_spk_),intent(in) :: alpha,beta
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
character,intent(in) :: trans
real(psb_spk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_smlprec_aply
end interface mld_mlprec_aply
interface mld_coarse_bld
subroutine mld_scoarse_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sonelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_scoarse_bld
end interface mld_coarse_bld
interface mld_aggrmap_bld
subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
integer, intent(in) :: aggr_type
real(psb_spk_), intent(in) :: theta
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
end subroutine mld_saggrmap_bld
end interface mld_aggrmap_bld
interface mld_aggrmat_asb
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sonelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_asb
end interface mld_aggrmat_asb
interface mld_aggrmat_nosmth_asb
subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sonelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_nosmth_asb
end interface mld_aggrmat_nosmth_asb
interface mld_aggrmat_smth_asb
subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sonelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_smth_asb
end interface mld_aggrmat_smth_asb
end module mld_s_inner_mod
mlprec/mld_s_jac_smoother.f90
+11 -4
View File
@@ -142,7 +142,8 @@ contains
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in sub_aply Jacobi Sweeps = 1')
call psb_errpush(psb_err_internal_error_,&
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
@@ -268,10 +269,16 @@ contains
end select
if (info == psb_success_) call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) &
& call sm%sv%build(a,desc_a,upd,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4')
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='clip & psb_spcnv csr 4')
goto 9999
end if
call sm%sv%build(a,desc_a,upd,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='solver build')
goto 9999
end if
nzeros = sm%nd%get_nzeros()
mlprec/mld_s_move_alloc_mod.f90
+102
View File
@@ -0,0 +1,102 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_move_alloc_mod.f90
!
! Module: mld_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_s_move_alloc_mod
use mld_s_prec_type
interface mld_move_alloc
module procedure mld_sonelev_prec_move_alloc,&
& mld_sprec_move_alloc
end interface
contains
subroutine mld_sonelev_prec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_sonelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call mld_precfree(b,info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_sonelev_prec_move_alloc
subroutine mld_sprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_sprec_type), intent(inout) :: a
type(mld_sprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i,isz
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, isz
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_sprec_move_alloc
end module mld_s_move_alloc_mod
mlprec/mld_s_prec_mod.f90
+162
View File
@@ -0,0 +1,162 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_prec_mod.f90
!
! Module: mld_prec_mod
!
! This module defines the interfaces to the real/complex, single/double
! precision versions of the user-level MLD2P4 routines.
!
module mld_s_prec_mod
use mld_s_prec_type
use mld_s_move_alloc_mod
interface mld_precinit
subroutine mld_sprecinit(p,ptype,info,nlev)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_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
end interface
interface mld_precset
module procedure mld_i_sprecseti, mld_i_sprecsetc, mld_i_sprecsetr
end interface
interface mld_inner_precset
subroutine mld_sprecsetsm(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_type, mld_s_base_smoother_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
class(mld_s_base_smoother_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_sprecsetsm
subroutine mld_sprecsetsv(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_type, mld_s_base_solver_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
class(mld_s_base_solver_type), intent(in) :: val
integer, intent(out) :: info
integer, optional, intent(in) :: ilev
end subroutine mld_sprecsetsv
subroutine mld_sprecseti(p,what,val,info,ilev)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_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_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_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_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_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
end interface
interface mld_precbld
subroutine mld_sprecbld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_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), target :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_sprecbld
end interface
contains
subroutine mld_i_sprecseti(p,what,val,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_sprecseti
subroutine mld_i_sprecsetr(p,what,val,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_sprecsetr
subroutine mld_i_sprecsetc(p,what,val,info)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_sprec_type
type(mld_sprec_type), intent(inout) :: p
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
call mld_inner_precset(p,what,val,info)
end subroutine mld_i_sprecsetc
end module mld_s_prec_mod
mlprec/mld_s_prec_type.f90
+500 -214
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_s_slu_solver.f90
+463
View File
@@ -0,0 +1,463 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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 mld_s_slu_solver
use iso_c_binding
use mld_s_prec_type
type, extends(mld_s_base_solver_type) :: mld_s_slu_solver_type
type(c_ptr) :: lufactors=c_null_ptr
integer(c_long_long) :: symbsize=0, numsize=0
contains
procedure, pass(sv) :: build => s_slu_solver_bld
procedure, pass(sv) :: apply => s_slu_solver_apply
procedure, pass(sv) :: free => s_slu_solver_free
procedure, pass(sv) :: seti => s_slu_solver_seti
procedure, pass(sv) :: setc => s_slu_solver_setc
procedure, pass(sv) :: setr => s_slu_solver_setr
procedure, pass(sv) :: descr => s_slu_solver_descr
procedure, pass(sv) :: sizeof => s_slu_solver_sizeof
end type mld_s_slu_solver_type
private :: s_slu_solver_bld, s_slu_solver_apply, &
& s_slu_solver_free, s_slu_solver_seti, &
& s_slu_solver_setc, s_slu_solver_setr,&
& s_slu_solver_descr, s_slu_solver_sizeof
interface
function mld_sslu_fact(n,nnz,values,rowptr,colind,&
& lufactors)&
& bind(c,name='mld_sslu_fact') result(info)
use iso_c_binding
integer(c_int), value :: n,nnz
integer(c_int) :: info
!integer(c_long_long) :: ssize, nsize
integer(c_int) :: rowptr(*),colind(*)
real(c_float) :: values(*)
type(c_ptr) :: lufactors
end function mld_sslu_fact
end interface
interface
function mld_sslu_solve(itrans,n,x, b, ldb, lufactors)&
& bind(c,name='mld_sslu_solve') result(info)
use iso_c_binding
integer(c_int) :: info
integer(c_int), value :: itrans,n,ldb
real(c_float) :: x(*), b(ldb,*)
type(c_ptr), value :: lufactors
end function mld_sslu_solve
end interface
interface
function mld_sslu_free(lufactors)&
& bind(c,name='mld_sslu_free') result(info)
use iso_c_binding
integer(c_int) :: info
type(c_ptr), value :: lufactors
end function mld_sslu_free
end interface
contains
subroutine s_slu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_slu_solver_type), intent(in) :: sv
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
integer :: n_row,n_col
real(psb_spk_), pointer :: ww(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='s_slu_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,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)
else
allocate(ww(n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
select case(trans_)
case('N')
info = mld_sslu_solve(0,n_row,ww,x,n_row,sv%lufactors)
case('T','C')
info = mld_sslu_solve(1,n_row,ww,x,n_row,sv%lufactors)
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in subsolve')
goto 9999
endif
if (n_col > size(work)) then
deallocate(ww)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_slu_solver_apply
subroutine s_slu_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_slu_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
! Local variables
type(psb_sspmat_type) :: atmp
type(psb_s_csr_sparse_mat) :: acsr
integer :: n_row,n_col, nrow_a, nztota
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='s_slu_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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),' start'
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
if (psb_toupper(upd) == 'F') then
call a%cscnv(atmp,info,type='coo')
call psb_rwextd(n_row,atmp,info,b=b)
call atmp%cscnv(info,type='csr',dupl=psb_dupl_add_)
call atmp%mv_to(acsr)
nrow_a = acsr%get_nrows()
nztota = acsr%get_nzeros()
! Fix the entres to call C-base SuperLU
acsr%ja(:) = acsr%ja(:) - 1
acsr%irp(:) = acsr%irp(:) - 1
info = mld_sslu_fact(nrow_a,nztota,acsr%val,&
& acsr%irp,acsr%ja,sv%lufactors)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_sslu_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call acsr%free()
call atmp%free()
else
! ?
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
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 == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_slu_solver_bld
subroutine s_slu_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_slu_solver_seti'
info = psb_success_
call psb_erractionsave(err_act)
select case(what)
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_slu_solver_seti
subroutine s_slu_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='s_slu_solver_setc'
info = psb_success_
call psb_erractionsave(err_act)
call mld_stringval(val,ival,info)
if (info == psb_success_) call sv%set(what,ival,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_slu_solver_setc
subroutine s_slu_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_slu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_slu_solver_setr'
call psb_erractionsave(err_act)
info = psb_success_
select case(what)
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
!!$ goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_slu_solver_setr
subroutine s_slu_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_slu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_slu_solver_free'
call psb_erractionsave(err_act)
info = mld_sslu_free(sv%lufactors)
if (info /= psb_success_) goto 9999
sv%lufactors = c_null_ptr
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_slu_solver_free
subroutine s_slu_solver_descr(sv,info,iout)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_slu_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_s_slu_solver_descr'
integer :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' SuperLU Sparse Factorization Solver. '
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_slu_solver_descr
function s_slu_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_s_slu_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 2*psb_sizeof_int + psb_sizeof_dp
val = val + sv%symbsize
val = val + sv%numsize
return
end function s_slu_solver_sizeof
end module mld_s_slu_solver
mlprec/mld_saggrmap_bld.f90
+2 -2
View File
@@ -82,7 +82,7 @@
subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_saggrmap_bld
use mld_s_inner_mod, mld_protect_name => mld_saggrmap_bld
implicit none
@@ -165,7 +165,7 @@ contains
subroutine mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
use psb_sparse_mod
use mld_inner_mod !, mld_protect_name => mld_daggrmap_bld
use mld_s_inner_mod !, mld_protect_name => mld_daggrmap_bld
implicit none
mlprec/mld_saggrmat_asb.f90
+2 -2
View File
@@ -101,7 +101,7 @@
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_saggrmat_asb
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_asb
implicit none
@@ -126,7 +126,7 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_info(ictxt, me, np)
select case (p%iprcparm(mld_aggr_kind_))
select case (p%parms%aggr_kind)
case (mld_no_smooth_)
call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
mlprec/mld_saggrmat_nosmth_asb.F90
+6 -6
View File
@@ -50,7 +50,7 @@
! 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_),
! replicated on each of them, according to the value of p%parms%coarse_mat
! specified by the user through mld_sprecinit and mld_sprecset.
!
! For details see
@@ -83,7 +83,7 @@
!
subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_saggrmat_nosmth_asb
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_nosmth_asb
#ifdef MPI_MOD
use mpi
@@ -136,7 +136,7 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1=sum(nlaggr(1:me))
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
do i=1, nrow
ilaggr(i) = ilaggr(i) + naggrm1
end do
@@ -148,7 +148,7 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
call acoo1%allocate(ncol,ntaggr,ncol)
else
call acoo1%allocate(ncol,naggr,ncol)
@@ -180,7 +180,7 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call bcoo%fix(info)
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
if (p%parms%coarse_mat == mld_repl_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
@@ -217,7 +217,7 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call ac_coo%fix(info)
call p%ac%mv_from(ac_coo)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
else if (p%parms%coarse_mat == mld_distr_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
mlprec/mld_saggrmat_smth_asb.F90
+22 -22
View File
@@ -58,7 +58,7 @@
! 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_omega_alg_), specified by the user
! according to the value of p%parms%aggr_omega_alg, specified by the user
! through mld_sprecinit and mld_sprecset.
!
! This routine can also build A_C according to a "bizarre" aggregation algorithm,
@@ -67,7 +67,7 @@
! 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_),
! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_sprecinit and mld_sprecset.
!
! For more details see
@@ -100,7 +100,7 @@
!
subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_saggrmat_smth_asb
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_smth_asb
#ifdef MPI_MOD
use mpi
@@ -150,7 +150,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
theta = p%rprcparm(mld_aggr_thresh_)
theta = p%parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
@@ -165,11 +165,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(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_)) )
ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.&
& ( (p%parms%aggr_kind == mld_biz_prol_).and.&
& (p%parms%coarse_mat == mld_repl_mat_)) )
filter_mat = (p%iprcparm(mld_aggr_filter_) == mld_filter_mat_)
filter_mat = (p%parms%aggr_filter == mld_filter_mat_)
if (ml_global_nmb) then
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
@@ -283,11 +283,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info /= psb_success_) goto 9999
if (p%iprcparm(mld_aggr_omega_alg_) == mld_eig_est_) then
if (p%parms%aggr_omega_alg == mld_eig_est_) then
if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then
if (p%parms%aggr_eig == mld_max_norm_) then
if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
if (p%parms%aggr_kind == mld_biz_prol_) then
!
! This only works with CSR
@@ -317,7 +317,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
omega = 4.d0/(3.d0*anorm)
p%rprcparm(mld_aggr_omega_val_) = omega
p%parms%aggr_omega_val = omega
else
info = psb_err_internal_error_
@@ -325,11 +325,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
else if (p%iprcparm(mld_aggr_omega_alg_) == mld_user_choice_) then
else if (p%parms%aggr_omega_alg == mld_user_choice_) then
omega = p%rprcparm(mld_aggr_omega_val_)
omega = p%parms%aggr_omega_val
else if (p%iprcparm(mld_aggr_omega_alg_) /= mld_user_choice_) then
else if (p%parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999
@@ -438,9 +438,9 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_numbmm(a,am1,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',p%iprcparm(mld_aggr_kind_), mld_smooth_prol_
& 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
if (p%parms%aggr_kind == mld_smooth_prol_) then
call am2%transp(am1)
call am2%mv_to(acoo2)
nzl = acoo2%get_nzeros()
@@ -472,13 +472,13 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
if (p%parms%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 == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call am4%free()
else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
else if (p%parms%aggr_kind == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info)
endif
if(info /= psb_success_) then
@@ -501,11 +501,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
select case(p%iprcparm(mld_aggr_kind_))
select case(p%parms%aggr_kind)
case(mld_smooth_prol_)
select case(p%iprcparm(mld_coarse_mat_))
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
@@ -593,7 +593,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
case(mld_biz_prol_)
select case(p%iprcparm(mld_coarse_mat_))
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
mlprec/mld_scoarse_bld.f90
+13 -18
View File
@@ -68,7 +68,7 @@
subroutine mld_scoarse_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_scoarse_bld
use mld_s_inner_mod, mld_protect_name => mld_scoarse_bld
implicit none
@@ -90,30 +90,25 @@ subroutine mld_scoarse_bld(a,desc_a,p,info)
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',&
call mld_check_def(p%parms%ml_type,'Multilevel type',&
& mld_mult_ml_,is_legal_ml_type)
call mld_check_def(p%iprcparm(mld_aggr_alg_),'Aggregation',&
call mld_check_def(p%parms%aggr_alg,'Aggregation',&
& mld_dec_aggr_,is_legal_ml_aggr_alg)
call mld_check_def(p%iprcparm(mld_aggr_kind_),'Smoother',&
call mld_check_def(p%parms%aggr_kind,'Smoother',&
& mld_smooth_prol_,is_legal_ml_aggr_kind)
call mld_check_def(p%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_legal_ml_coarse_mat)
call mld_check_def(p%iprcparm(mld_aggr_filter_),'Use filtered matrix',&
call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',&
& mld_no_filter_mat_,is_legal_aggr_filter)
call mld_check_def(p%iprcparm(mld_smoother_pos_),'smooth_pos',&
call mld_check_def(p%parms%smoother_pos,'smooth_pos',&
& mld_pre_smooth_,is_legal_ml_smooth_pos)
call mld_check_def(p%iprcparm(mld_aggr_omega_alg_),'Omega Alg.',&
call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',&
& mld_eig_est_,is_legal_ml_aggr_omega_alg)
call mld_check_def(p%iprcparm(mld_aggr_eig_),'Eigenvalue estimate',&
call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',&
& mld_max_norm_,is_legal_ml_aggr_eig)
call mld_check_def(p%rprcparm(mld_aggr_omega_val_),'Omega',szero,is_legal_s_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
call mld_check_def(p%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega)
call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
!
! Build a mapping between the row indices of the fine-level matrix
@@ -121,7 +116,7 @@ subroutine mld_scoarse_bld(a,desc_a,p,info)
! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level.
!
call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),&
call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_thresh,&
& a,desc_a,ilaggr,nlaggr,info)
if (info /= psb_success_) then
mlprec/mld_silu0_fact.f90
+1 -1
View File
@@ -102,7 +102,7 @@
subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck,upd)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_silu0_fact
use mld_s_inner_mod!, mld_protect_name => mld_silu0_fact
implicit none
mlprec/mld_siluk_fact.f90
+1 -1
View File
@@ -99,7 +99,7 @@
subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_siluk_fact
use mld_s_inner_mod!, mld_protect_name => mld_siluk_fact
implicit none
mlprec/mld_silut_fact.f90
+1 -1
View File
@@ -95,7 +95,7 @@
subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck)
use psb_sparse_mod
use mld_inner_mod!, mld_protect_name => mld_silut_fact
use mld_s_inner_mod!, mld_protect_name => mld_silut_fact
implicit none
mlprec/mld_smlprec_aply.f90
+26 -26
View File
@@ -171,7 +171,8 @@
!
!
! Additive multilevel
! This is additive both within the levels and among levels.
!
! This is additive both within the levels and among levels.
!
! For details on the additive multilevel Schwarz preconditioner see the
! Algorithm 3.1.1 in the book:
@@ -203,7 +204,7 @@
!
!
!
! Hybrid multiplicative---pre-smoothing
! Hybrid multiplicative, pre-smoothing only
!
! The preconditioner M is hybrid in the sense that it is multiplicative through the
! levels and additive inside a level.
@@ -315,7 +316,7 @@
subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_smlprec_aply
use mld_s_inner_mod, mld_protect_name => mld_smlprec_aply
implicit none
@@ -357,7 +358,8 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
nlev = size(p%precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='Allocate')
goto 9999
end if
level = 1
@@ -455,13 +457,12 @@ contains
end if
end if
select case(p%precv(level)%iprcparm(mld_ml_type_))
select case(p%precv(level)%parms%ml_type)
case(mld_no_ml_)
!
! No preconditioning, should not really get here
!
write(0,*) 'MLD_NO_ML_ in inner_ml ',level
call psb_errpush(psb_err_internal_error_,name,&
& a_err='mld_no_ml_ in mlprc_aply?')
goto 9999
@@ -485,13 +486,12 @@ contains
end if
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) goto 9999
if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
@@ -514,8 +514,7 @@ contains
! Pre/post-smoothing versions.
! Note that the transpose switches pre <-> post.
!
select case(p%precv(level)%iprcparm(mld_smoother_pos_))
select case(p%precv(level)%parms%smoother_pos)
case(mld_post_smooth_)
@@ -555,13 +554,13 @@ contains
& work=work,trans=trans)
if (info /= psb_success_) goto 9999
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -593,9 +592,9 @@ contains
! Apply the base preconditioner
!
if (level < nlev) then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
@@ -653,9 +652,9 @@ contains
! Apply the base preconditioner
!
if (level < nlev) then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
@@ -720,13 +719,13 @@ contains
& work=work,trans=trans)
if (info /= psb_success_) goto 9999
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
@@ -763,19 +762,20 @@ contains
goto 9999
end if
end if
call psb_geaxpby(sone,mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%tx,&
call psb_geaxpby(sone,mlprec_wrk(level)%x2l,szero,&
& mlprec_wrk(level)%tx,&
& p%precv(level)%base_desc,info)
!
! Apply the base preconditioner
!
if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
end if
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_)
sweeps = p%precv(level)%parms%sweeps
end if
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
@@ -817,9 +817,9 @@ contains
! Apply the base preconditioner
!
if (trans == 'N') then
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_post_)
sweeps = p%precv(level)%parms%sweeps_post
else
sweeps = p%precv(level)%iprcparm(mld_smoother_sweeps_pre_)
sweeps = p%precv(level)%parms%sweeps_pre
end if
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,&
@@ -836,7 +836,7 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/p%precv(level)%iprcparm(mld_smoother_pos_),0,0,0,0/))
& i_Err=(/p%precv(level)%parms%smoother_pos,0,0,0,0/))
goto 9999
end select
@@ -844,7 +844,7 @@ contains
case default
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/p%precv(level)%iprcparm(mld_ml_type_),0,0,0,0/))
& i_Err=(/p%precv(level)%parms%ml_type,0,0,0,0/))
goto 9999
end select
mlprec/mld_smlprec_bld.f90
+79 -161
View File
@@ -67,12 +67,8 @@
subroutine mld_smlprec_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_smlprec_bld
use mld_prec_mod
use mld_s_jac_smoother
use mld_s_as_smoother
use mld_s_diag_solver
use mld_s_ilu_solver
use mld_s_inner_mod, mld_protect_name => mld_smlprec_bld
use mld_s_prec_mod
Implicit None
@@ -89,6 +85,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
integer :: ipv(mld_ifpsz_), val
integer :: int_err(5)
character :: upd_
type(mld_sml_parms) :: prm
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -162,17 +159,10 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%precv(1)%iprcparm(:) = ipv(:)
end if
call psb_bcast(ictxt,p%precv(1)%parms)
!
! Finest level first; remember to fix base_a and base_desc
!
call init_baseprec_av(p%precv(1)%prec,info)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
@@ -187,13 +177,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(i)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(i)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, resetting.'
p%precv(i)%iprcparm(:) = ipv(:)
end if
call psb_bcast(ictxt,p%precv(1)%parms)
!
! Sanity checks on the parameters
@@ -202,12 +186,12 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%precv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
call check_coarse_lev(p%precv(i))
!!$ call check_coarse_lev(p%precv(i))
end if
@@ -218,7 +202,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
! Build the mapping between levels i-1 and i and the matrix
! at level i
!
call init_baseprec_av(p%precv(i)%prec,info)
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
@@ -284,7 +267,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
i = iszv
call check_coarse_lev(p%precv(i))
call init_baseprec_av(p%precv(i)%prec,info)
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then
@@ -301,75 +283,30 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
select case(p%precv(i)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%precv(i)%prec%iprcparm(mld_sub_fillin_),&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%precv(i)%prec%rprcparm(mld_sub_iluthrs_),&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_),&
call mld_check_def(p%precv(i)%parms%sweeps,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_pre_),&
call mld_check_def(p%precv(i)%parms%sweeps_pre,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_post_),&
call mld_check_def(p%precv(i)%parms%sweeps_post,&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
if (.not.allocated(p%precv(i)%sm)) then
!! Error: should have called mld_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (.not.allocated(p%precv(i)%sm%sv)) then
!! Error: should have called mld_dprecinit
info=3111
call psb_errpush(info,name)
goto 9999
end if
!
! Test version for beginning of OO stuff.
!
if (allocated(p%precv(i)%sm)) then
call p%precv(i)%sm%free(info)
if (info == psb_success_) deallocate(p%precv(i)%sm,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
end if
select case (p%precv(i)%prec%iprcparm(mld_smoother_type_))
case(mld_bjac_, mld_jac_)
allocate(mld_s_jac_smoother_type :: p%precv(i)%sm, stat=info)
case(mld_as_)
allocate(mld_s_as_smoother_type :: p%precv(i)%sm, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Smoother allocation error',info,&
& p%precv(i)%prec%iprcparm(mld_smoother_type_)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(i)%sm%set(mld_sub_restr_,p%precv(i)%prec%iprcparm(mld_sub_restr_),info)
call p%precv(i)%sm%set(mld_sub_prol_,p%precv(i)%prec%iprcparm(mld_sub_prol_),info)
call p%precv(i)%sm%set(mld_sub_ovr_,p%precv(i)%prec%iprcparm(mld_sub_ovr_),info)
select case (p%precv(i)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
allocate(mld_s_ilu_solver_type :: p%precv(i)%sm%sv, stat=info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_solve_,&
& p%precv(i)%prec%iprcparm(mld_sub_solve_),info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_fillin_,&
& p%precv(i)%prec%iprcparm(mld_sub_fillin_),info)
if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_iluthrs_,&
& p%precv(i)%prec%rprcparm(mld_sub_iluthrs_),info)
case(mld_diag_scale_)
allocate(mld_s_diag_solver_type :: p%precv(i)%sm%sv, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Solver allocation error',info,&
& p%precv(i)%prec%iprcparm(mld_sub_solve_)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,'F',info)
if (info /= psb_success_) then
@@ -397,86 +334,67 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
contains
subroutine init_baseprec_av(p,info)
type(mld_sbaseprec_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 /= psb_success_) return
!!$ endif
!!$ end if
!!$ if (.not.(allocated(p%av))) then
!!$ allocate(p%av(mld_max_avsz_),stat=info)
!!$ if (info /= psb_success_) return
!!$ end if
!!$ do k=1,size(p%av)
!!$ call psb_nullify_sp(p%av(k))
!!$ end do
end subroutine init_baseprec_av
subroutine check_coarse_lev(prec)
type(mld_sonelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
val = prec%iprcparm(mld_coarse_solve_)
select case (val)
case(mld_jac_)
if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
end if
prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
case(mld_bjac_)
if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
& ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
!!$#if defined(HAVE_UMF_)
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$#elif defined(HAVE_SLU_)
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$#else
prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$#endif
end if
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
case(mld_umf_, mld_slu_)
if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
prec%prec%iprcparm(mld_sub_solve_) = val
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
end if
case(mld_sludist_)
if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
prec%prec%iprcparm(mld_sub_solve_) = val
prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
prec%prec%iprcparm(mld_smoother_sweeps_) = 1
end if
end select
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_smlprec_bld
mlprec/mld_sprecaply.f90
+3 -3
View File
@@ -74,7 +74,7 @@
subroutine mld_sprecaply(prec,x,y,desc_data,info,trans,work)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_sprecaply
use mld_s_inner_mod, mld_protect_name => mld_sprecaply
implicit none
@@ -140,7 +140,7 @@ subroutine mld_sprecaply(prec,x,y,desc_data,info,trans,work)
! Number of levels = 1: apply the base preconditioner
!
call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,&
& prec%precv(1)%iprcparm(mld_smoother_sweeps_), work_,info)
& prec%precv(1)%parms%sweeps, work_,info)
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
@@ -206,7 +206,7 @@ end subroutine mld_sprecaply
subroutine mld_sprecaply1(prec,x,desc_data,info,trans)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_sprecaply1
use mld_s_inner_mod, mld_protect_name => mld_sprecaply1
implicit none
mlprec/mld_sprecbld.f90
+22 -108
View File
@@ -61,12 +61,8 @@
subroutine mld_sprecbld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod
use mld_prec_mod, mld_protect_name => mld_sprecbld
use mld_s_jac_smoother
use mld_s_as_smoother
use mld_s_diag_solver
use mld_s_ilu_solver
use mld_s_inner_mod
use mld_s_prec_mod, mld_protect_name => mld_sprecbld
Implicit None
@@ -83,6 +79,7 @@ subroutine mld_sprecbld(a,desc_a,p,info)
integer :: ipv(mld_ifpsz_), val
integer :: int_err(5)
character :: upd_
type(mld_sml_parms) :: prm
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
@@ -155,17 +152,8 @@ subroutine mld_sprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%precv(1)%iprcparm(:) = ipv(:)
end if
!
! Remember to fix base_a and base_desc
!
call init_baseprec_av(p%precv(1)%prec,info)
call psb_bcast(ictxt,p%precv(1)%parms)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
@@ -173,89 +161,35 @@ subroutine mld_sprecbld(a,desc_a,p,info)
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Build the base preconditioner
!
select case(p%precv(1)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%precv(1)%prec%iprcparm(mld_sub_fillin_),&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%precv(1)%prec%rprcparm(mld_sub_iluthrs_),&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
call mld_check_def(p%precv(1)%iprcparm(mld_smoother_sweeps_),&
& 'Jacobi sweeps',1,is_legal_jac_sweeps)
!
! Test version for beginning of OO stuff.
!
if (allocated(p%precv(1)%sm)) then
call p%precv(1)%sm%free(info)
if (info == psb_success_) deallocate(p%precv(1)%sm,stat=info)
call p%precv(1)%check(info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name,a_err='One level preconditioner build.')
write(0,*) ' Smoother check error',info
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner check.')
goto 9999
endif
end if
select case (p%precv(1)%prec%iprcparm(mld_smoother_type_))
case(mld_jac_, mld_bjac_)
allocate(mld_s_jac_smoother_type :: p%precv(1)%sm, stat=info)
case(mld_as_)
allocate(mld_s_as_smoother_type :: p%precv(1)%sm, stat=info)
case default
info = -1
end select
if (info /= psb_success_) then
write(0,*) ' Smoother allocation error',info,&
& p%precv(1)%prec%iprcparm(mld_smoother_type_)
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(1)%sm%set(mld_sub_restr_,p%precv(1)%prec%iprcparm(mld_sub_restr_),info)
call p%precv(1)%sm%set(mld_sub_prol_,p%precv(1)%prec%iprcparm(mld_sub_prol_),info)
call p%precv(1)%sm%set(mld_sub_ovr_,p%precv(1)%prec%iprcparm(mld_sub_ovr_),info)
select case (p%precv(1)%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
allocate(mld_s_ilu_solver_type :: p%precv(1)%sm%sv, stat=info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_solve_,&
& p%precv(1)%prec%iprcparm(mld_sub_solve_),info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_fillin_,&
& p%precv(1)%prec%iprcparm(mld_sub_fillin_),info)
if (info == psb_success_) call p%precv(1)%sm%sv%set(mld_sub_iluthrs_,&
& p%precv(1)%prec%rprcparm(mld_sub_iluthrs_),info)
case(mld_diag_scale_)
allocate(mld_s_diag_solver_type :: p%precv(1)%sm%sv, stat=info)
case default
info = -1
end select
call p%precv(1)%sm%build(a,desc_a,upd_,info)
if (info /= psb_success_) then
write(0,*) ' Smoother build error',info
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
if (info /= psb_success_) then
write(0,*) ' Solver allocation error',info,&
& p%precv(1)%prec%iprcparm(mld_sub_solve_)
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
call p%precv(1)%sm%build(a,desc_a,upd_,info)
if (info /= psb_success_) then
write(0,*) ' Smoother build error',info
call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.')
goto 9999
endif
!
! Number of levels > 1
!
!
! Number of levels > 1
!
else if (iszv > 1) then
!
! Build the multilevel preconditioner
!
call mld_mlprec_bld(a,desc_a,p,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Multilevel preconditioner build.')
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Multilevel preconditioner build.')
goto 9999
endif
end if
@@ -271,25 +205,5 @@ subroutine mld_sprecbld(a,desc_a,p,info)
end if
return
contains
subroutine init_baseprec_av(p,info)
type(mld_sbaseprec_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 /= psb_success_) return
!!$ endif
!!$ end if
!!$ if (.not.(allocated(p%av))) then
!!$ allocate(p%av(mld_max_avsz_),stat=info)
!!$ if (info /= psb_success_) return
!!$ end if
!!$ do k=1,size(p%av)
!!$ call psb_nullify_sp(p%av(k))
!!$ end do
end subroutine init_baseprec_av
end subroutine mld_sprecbld
mlprec/mld_sprecinit.F90
+41 -167
View File
@@ -91,11 +91,15 @@
subroutine mld_sprecinit(p,ptype,info,nlev)
use psb_sparse_mod
use mld_prec_mod, mld_protect_name => mld_sprecinit
use mld_s_prec_mod, mld_protect_name => mld_sprecinit
use mld_s_jac_smoother
use mld_s_as_smoother
use mld_s_id_solver
use mld_s_diag_solver
use mld_s_ilu_solver
#if defined(HAVE_SLU_)
use mld_s_slu_solver
#endif
implicit none
@@ -119,104 +123,41 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
endif
select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC')
case ('NOPREC','NONE')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_s_base_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_noprec_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_s_id_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('JAC','DIAG','JACOBI')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_s_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_s_diag_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('BJAC')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_s_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_s_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('AS')
nlev_ = 1
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_s_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
allocate(mld_s_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
case ('ML')
@@ -228,103 +169,36 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
end if
ilev_ = 1
allocate(p%precv(nlev_),stat=info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_s_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
if (nlev_ == 1) return
allocate(mld_s_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_s_as_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 1
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 1
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
allocate(mld_s_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
call p%precv(ilev_)%default()
end do
ilev_ = nlev_
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == psb_success_) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == psb_success_) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
allocate(mld_s_jac_smoother_type :: p%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_coarse_solve_) = mld_bjac_
#if defined(HAVE_SLU_)
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_slu_
#if defined(HAVE_SLU_)
allocate(mld_s_slu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
#else
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
allocate(mld_s_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info)
#endif
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = 4
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = 4
p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 4
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_twoside_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%iprcparm(mld_aggr_filter_) = mld_no_filter_mat_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
call p%precv(ilev_)%default()
call p%precv(ilev_)%set(mld_smoother_sweeps_,4,info)
call p%precv(ilev_)%set(mld_sub_restr_,psb_none_,info)
call p%precv(ilev_)%set(mld_sub_prol_,psb_none_,info)
call p%precv(ilev_)%set(mld_sub_ovr_,0,info)
!!$ write(0,*) 'Check 5: ',allocated(p%precv(1)%sm)
case default
write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"'
mlprec/mld_sprecset.F90
+356 -683
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_sslu_bld.f90
+1 -1
View File
@@ -72,7 +72,7 @@
subroutine mld_sslu_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_sslu_bld
use mld_s_inner_mod, mld_protect_name => mld_sslu_bld
implicit none
mlprec/mld_sslu_interface.c
+45 -116
View File
@@ -116,50 +116,10 @@ typedef struct {
#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)
int
mld_sslu_fact(int n, int nnz, float *values,
int *rowptr, int *colind, void **f_factors)
{
/*
@@ -187,6 +147,7 @@ mld_sslu_fact_(int *n, int *nnz,
superlu_options_t options;
SuperLUStat_t stat;
factors_t *LUfactors;
int info;
trans = NOTRANS;
@@ -197,17 +158,13 @@ mld_sslu_fact_(int *n, int *nnz,
/* 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,
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[].");
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:
@@ -226,9 +183,9 @@ mld_sslu_fact_(int *n, int *nnz,
relax = sp_ienv(2);
sgstrf(&options, &AC, drop_tol, relax, panel_size,
etree, NULL, 0, perm_c, perm_r, L, U, &stat, info);
etree, NULL, 0, perm_c, perm_r, L, U, &stat, &info);
if ( *info == 0 ) {
if ( info == 0 ) {
Lstore = (SCformat *) L->Store;
Ustore = (NCformat *) U->Store;
sQuerySpace(L, U, &mem_usage);
@@ -241,8 +198,8 @@ mld_sslu_fact_(int *n, int *nnz,
mem_usage.expansions);
#endif
} else {
printf("dgstrf() error returns INFO= %d\n", *info);
if ( *info <= *n ) { /* factorization completes */
printf("sgstrf() 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,
@@ -250,49 +207,40 @@ mld_sslu_fact_(int *n, int *nnz,
}
}
/* 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;
*f_factors = (void *) LUfactors;
/* Free un-wanted storage */
SUPERLU_FREE(etree);
Destroy_SuperMatrix_Store(&A);
Destroy_CompCol_Permuted(&AC);
StatFree(&stat);
return(info);
#else
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
*info=-1;
return(-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)
int
mld_sslu_solve(int itrans, int n, int nrhs, float *b, int ldb,
void *f_factors)
{
/*
* This routine can be called from Fortran.
* performs triangular solve
*
*/
/*
* This routine can be called from Fortran.
* performs triangular solve
*
*/
int info;
#ifdef Have_SLU_
SuperMatrix A, AC, B;
SuperMatrix B;
SuperMatrix *L, *U;
int *perm_r; /* row permutations from partial pivoting */
int *perm_c; /* column permutation vector */
@@ -305,11 +253,11 @@ mld_sslu_solve_(int *itrans, int *n, int *nrhs,
SuperLUStat_t stat;
factors_t *LUfactors;
if (*itrans == 0) {
if (itrans == 0) {
trans = NOTRANS;
} else if (*itrans ==1) {
} else if (itrans ==1) {
trans = TRANS;
} else if (*itrans ==2) {
} else if (itrans ==2) {
trans = CONJ;
} else {
trans = NOTRANS;
@@ -318,35 +266,28 @@ mld_sslu_solve_(int *itrans, int *n, int *nrhs,
StatInit(&stat);
/* Extract the LU factors in the factors handle */
LUfactors = (factors_t*) *f_factors;
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);
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);
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;
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
info=-1;
#endif
return(info);
}
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)
int
mld_sslu_free(void *f_factors)
{
/*
@@ -356,24 +297,11 @@ mld_sslu_free_(
*
*/
#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;
factors_t *LUfactors;
/* Free the LU factors in the factors handle */
LUfactors = (factors_t*) f_factors;
if (LUfactors != NULL) {
SUPERLU_FREE (LUfactors->perm_r);
SUPERLU_FREE (LUfactors->perm_c);
Destroy_SuperNode_Matrix(LUfactors->L);
@@ -381,10 +309,11 @@ mld_sslu_free_(
SUPERLU_FREE (LUfactors->L);
SUPERLU_FREE (LUfactors->U);
SUPERLU_FREE (LUfactors);
*info = 0;
}
return(0);
#else
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
*info=-1;
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
return(-1);
#endif
}
mlprec/mld_sslud_bld.f90
+1 -1
View File
@@ -69,7 +69,7 @@
subroutine mld_ssludist_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_ssludist_bld
use mld_s_inner_mod, mld_protect_name => mld_ssludist_bld
implicit none
mlprec/mld_ssp_renum.f90
+1 -1
View File
@@ -84,7 +84,7 @@
subroutine mld_ssp_renum(a,blck,p,atmp,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_ssp_renum
use mld_s_inner_mod, mld_protect_name => mld_ssp_renum
implicit none
mlprec/mld_sumf_bld.f90
+1 -1
View File
@@ -78,7 +78,7 @@
subroutine mld_sumf_bld(a,desc_a,p,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_sumf_bld
use mld_s_inner_mod, mld_protect_name => mld_sumf_bld
implicit none
mlprec/mld_z_as_smoother.f90
+128 -7
View File
@@ -53,8 +53,10 @@ module mld_z_as_smoother
!
type(psb_zspmat_type) :: nd
type(psb_desc_type) :: desc_data
integer :: novr, restr, prol
integer :: novr, restr, prol, nd_nnz_tot
contains
procedure, pass(sm) :: check => z_as_smoother_check
procedure, pass(sm) :: dump => z_as_smoother_dmp
procedure, pass(sm) :: build => z_as_smoother_bld
procedure, pass(sm) :: apply => z_as_smoother_apply
procedure, pass(sm) :: free => z_as_smoother_free
@@ -63,13 +65,16 @@ module mld_z_as_smoother
procedure, pass(sm) :: setr => z_as_smoother_setr
procedure, pass(sm) :: descr => z_as_smoother_descr
procedure, pass(sm) :: sizeof => z_as_smoother_sizeof
procedure, pass(sm) :: default => z_as_smoother_default
end type mld_z_as_smoother_type
private :: z_as_smoother_bld, z_as_smoother_apply, &
& z_as_smoother_free, z_as_smoother_seti, &
& z_as_smoother_setc, z_as_smoother_setr,&
& z_as_smoother_descr, z_as_smoother_sizeof
& z_as_smoother_descr, z_as_smoother_sizeof, &
& z_as_smoother_check, z_as_smoother_default,&
& z_as_smoother_dmp
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
@@ -79,6 +84,73 @@ module mld_z_as_smoother
contains
subroutine z_as_smoother_default(sm)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_as_smoother_type), intent(inout) :: sm
sm%restr = psb_halo_
sm%prol = psb_none_
sm%novr = 1
if (allocated(sm%sv)) then
call sm%sv%default()
end if
return
end subroutine z_as_smoother_default
subroutine z_as_smoother_check(sm,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_as_smoother_type), intent(inout) :: sm
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='z_as_smoother_check'
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(sm%restr,&
& 'Restrictor',psb_halo_,is_legal_restrict)
call mld_check_def(sm%prol,&
& 'Prolongator',psb_none_,is_legal_prolong)
call mld_check_def(sm%novr,&
& 'Overlap layers ',0,is_legal_n_ovr)
if (allocated(sm%sv)) then
call sm%sv%check(info)
else
info=3111
call psb_errpush(info,name)
goto 9999
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine z_as_smoother_check
subroutine z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
@@ -100,6 +172,8 @@ contains
call psb_erractionsave(err_act)
info = psb_success_
ictxt = psb_cd_get_context(desc_data)
call psb_info (ictxt,me,np)
trans_ = psb_toupper(trans)
select case(trans_)
@@ -401,7 +475,7 @@ contains
! and Y(j) is the approximate solution at sweep j.
!
ww(1:n_row) = tx(1:n_row)
call psb_spmm(-zone,sm%nd,tx,zone,ww,sm%desc_data,info,work=aux,trans=trans_)
call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
@@ -525,7 +599,7 @@ contains
integer, intent(out) :: info
! Local variables
type(psb_zspmat_type) :: blck, atmp
integer :: n_row,n_col, nrow_a, nhalo, novr, data_
integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='z_as_smoother_bld', ch_err
@@ -631,6 +705,10 @@ contains
call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4')
goto 9999
end if
nzeros = sm%nd%get_nzeros()
!!$ write(0,*) me,' ND nzeors ',nzeros
call psb_sum(ictxt,nzeros)
sm%nd_nnz_tot = nzeros
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
@@ -677,9 +755,6 @@ contains
case default
if (allocated(sm%sv)) then
call sm%sv%set(what,val,info)
!!$ else
!!$ write(0,*) trim(name),' Missing component, not setting!'
!!$ info = 1121
end if
end select
@@ -871,4 +946,50 @@ contains
return
end function z_as_smoother_sizeof
subroutine z_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
use psb_sparse_mod
implicit none
class(mld_z_as_smoother_type), intent(in) :: sm
integer, intent(in) :: ictxt,level
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver
integer :: i, j, il1, iln, lname, lev
integer :: icontxt,iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
logical :: smoother_
! len of prefix_
info = 0
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_smth_c"
end if
call psb_info(ictxt,iam,np)
if (present(smoother)) then
smoother_ = smoother
else
smoother_ = .false.
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
lname = lname + 5
if (smoother_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
if (sm%nd%is_asb()) &
& call sm%nd%print(fname,head=head)
end if
! At base level do nothing for the smoother
if (allocated(sm%sv)) &
& call sm%sv%dump(ictxt,level,info,solver=solver)
end subroutine z_as_smoother_dmp
end module mld_z_as_smoother
mlprec/mld_z_id_solver.f90
+280
View File
@@ -0,0 +1,280 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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.
!!$
!!$
!
!
!
! Identity solver. Reference for nullprec.
!
!
module mld_z_id_solver
use mld_z_prec_type
type, extends(mld_z_base_solver_type) :: mld_z_id_solver_type
contains
procedure, pass(sv) :: build => z_id_solver_bld
procedure, pass(sv) :: apply => z_id_solver_apply
procedure, pass(sv) :: free => z_id_solver_free
procedure, pass(sv) :: seti => z_id_solver_seti
procedure, pass(sv) :: setc => z_id_solver_setc
procedure, pass(sv) :: setr => z_id_solver_setr
procedure, pass(sv) :: descr => z_id_solver_descr
procedure, pass(sv) :: sizeof => z_id_solver_sizeof
end type mld_z_id_solver_type
private :: z_id_solver_bld, z_id_solver_apply, &
& z_id_solver_free, z_id_solver_seti, &
& z_id_solver_setc, z_id_solver_setr,&
& z_id_solver_descr, z_id_solver_sizeof
contains
subroutine z_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_z_id_solver_type), intent(in) :: sv
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer :: n_row,n_col
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='z_id_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine z_id_solver_apply
subroutine z_id_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_zspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_z_id_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_zspmat_type), intent(in), target, optional :: b
! Local variables
integer :: n_row,n_col, nrow_a, nztota
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='z_id_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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),' start'
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 == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine z_id_solver_bld
subroutine z_id_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='z_id_solver_seti'
info = psb_success_
return
end subroutine z_id_solver_seti
subroutine z_id_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='z_id_solver_setc'
info = psb_success_
return
end subroutine z_id_solver_setc
subroutine z_id_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_id_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='z_id_solver_setr'
info = psb_success_
return
end subroutine z_id_solver_setr
subroutine z_id_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_id_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='z_id_solver_free'
info = psb_success_
return
end subroutine z_id_solver_free
subroutine z_id_solver_descr(sv,info,iout)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_id_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_z_id_solver_descr'
integer :: iout_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' Identity local solver '
return
end subroutine z_id_solver_descr
function z_id_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_z_id_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 0
return
end function z_id_solver_sizeof
end module mld_z_id_solver
mlprec/mld_z_ilu_solver.f90
+130 -11
View File
@@ -53,6 +53,7 @@ module mld_z_ilu_solver
integer :: fact_type, fill_in
real(psb_dpk_) :: thresh
contains
procedure, pass(sv) :: dump => z_ilu_solver_dmp
procedure, pass(sv) :: build => z_ilu_solver_bld
procedure, pass(sv) :: apply => z_ilu_solver_apply
procedure, pass(sv) :: free => z_ilu_solver_free
@@ -61,13 +62,15 @@ module mld_z_ilu_solver
procedure, pass(sv) :: setr => z_ilu_solver_setr
procedure, pass(sv) :: descr => z_ilu_solver_descr
procedure, pass(sv) :: sizeof => z_ilu_solver_sizeof
procedure, pass(sv) :: default => z_ilu_solver_default
end type mld_z_ilu_solver_type
private :: z_ilu_solver_bld, z_ilu_solver_apply, &
& z_ilu_solver_free, z_ilu_solver_seti, &
& z_ilu_solver_setc, z_ilu_solver_setr,&
& z_ilu_solver_descr, z_ilu_solver_sizeof
& z_ilu_solver_descr, z_ilu_solver_sizeof, &
& z_ilu_solver_default, z_ilu_solver_dmp
interface mld_ilu0_fact
@@ -109,13 +112,74 @@ module mld_z_ilu_solver
end interface
character(len=15), parameter, private :: &
& fact_names(0:4)=(/'none ','DIAG ?? ',&
& fact_names(0:mld_slv_delta_+4)=(/&
& 'none ','none ',&
& 'none ','none ',&
& 'none ','DIAG ?? ',&
& 'ILU(n) ',&
& 'MILU(n) ','ILU(t,n) '/)
contains
subroutine z_ilu_solver_default(sv)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_ilu_solver_type), intent(inout) :: sv
sv%fact_type = mld_ilu_n_
sv%fill_in = 0
sv%thresh = szero
return
end subroutine z_ilu_solver_default
subroutine z_ilu_solver_check(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_z_ilu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='z_ilu_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
call mld_check_def(sv%fact_type,&
& 'Factorization',mld_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(sv%fill_in,&
& 'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(sv%thresh,&
& 'Eps',dzero,is_legal_fact_thrs)
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine z_ilu_solver_check
subroutine z_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
@@ -131,7 +195,7 @@ contains
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_ilu_solver_apply'
character(len=20) :: name='z_ilu_solver_apply'
call psb_erractionsave(err_act)
@@ -236,7 +300,7 @@ contains
integer :: n_row,n_col, nrow_a, nztota
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_ilu_solver_bld', ch_err
character(len=20) :: name='z_ilu_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
@@ -291,7 +355,8 @@ contains
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/))
call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/3,sv%fill_in,0,0,0/))
goto 9999
case(0:)
@@ -313,7 +378,8 @@ contains
select case(sv%fill_in)
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/))
call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/3,sv%fill_in,0,0,0/))
goto 9999
case(0)
! Fill-in 0
@@ -343,7 +409,9 @@ contains
case default
! If we end up here, something was wrong up in the call chain.
call psb_errpush(psb_err_alloc_dealloc_,name)
info = psb_err_input_value_invalid_i_
call psb_errpush(psb_err_input_value_invalid_i_,name,&
& i_err=(/3,sv%fact_type,0,0,0/))
goto 9999
end select
@@ -399,7 +467,7 @@ contains
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_seti'
character(len=20) :: name='z_ilu_solver_seti'
info = psb_success_
call psb_erractionsave(err_act)
@@ -438,7 +506,7 @@ contains
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_ilu_solver_setc'
character(len=20) :: name='z_ilu_solver_setc'
info = psb_success_
call psb_erractionsave(err_act)
@@ -476,7 +544,7 @@ contains
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_setr'
character(len=20) :: name='z_ilu_solver_setr'
call psb_erractionsave(err_act)
info = psb_success_
@@ -512,7 +580,7 @@ contains
class(mld_z_ilu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_free'
character(len=20) :: name='z_ilu_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
@@ -603,4 +671,55 @@ contains
return
end function z_ilu_solver_sizeof
subroutine z_ilu_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
use psb_sparse_mod
implicit none
class(mld_z_ilu_solver_type), intent(in) :: sv
integer, intent(in) :: ictxt,level
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: solver
integer :: i, j, il1, iln, lname, lev
integer :: icontxt,iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
logical :: solver_
! len of prefix_
info = 0
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_slv_d"
end if
call psb_info(ictxt,iam,np)
if (present(solver)) then
solver_ = solver
else
solver_ = .false.
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
lname = lname + 5
if (solver_) then
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_lower.mtx'
if (sv%l%is_asb()) &
& call sv%l%print(fname,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx'
if (allocated(sv%d)) &
& call psb_geprt(fname,sv%d,head=head)
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_upper.mtx'
if (sv%u%is_asb()) &
& call sv%u%print(fname,head=head)
end if
end subroutine z_ilu_solver_dmp
end module mld_z_ilu_solver
mlprec/mld_z_inner_mod.f90
+141
View File
@@ -0,0 +1,141 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_inner_mod.f90
!
! Module: mld_inner_mod
!
! This module defines the interfaces to the real/complex, single/double
! precision versions of the MLD2P4 routines, except those of the user level,
! whose interfaces are defined in mld_prec_mod.f90.
!
module mld_z_inner_mod
use mld_z_prec_type
use mld_z_move_alloc_mod
interface mld_mlprec_bld
subroutine mld_zmlprec_bld(a,desc_a,prec,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_zprec_type
implicit none
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_zprec_type), intent(inout) :: prec
integer, intent(out) :: info
!!$ character, intent(in),optional :: upd
end subroutine mld_zmlprec_bld
end interface mld_mlprec_bld
interface mld_mlprec_aply
subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_zprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_zprec_type), intent(in) :: p
complex(psb_dpk_),intent(in) :: alpha,beta
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
character,intent(in) :: trans
complex(psb_dpk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_zmlprec_aply
end interface mld_mlprec_aply
interface mld_coarse_bld
subroutine mld_zcoarse_bld(a,desc_a,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_zonelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(mld_zonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zcoarse_bld
end interface mld_coarse_bld
interface mld_aggrmap_bld
subroutine mld_zaggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
integer, intent(in) :: aggr_type
real(psb_dpk_), intent(in) :: theta
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
end subroutine mld_zaggrmap_bld
end interface mld_aggrmap_bld
interface mld_aggrmat_asb
subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_zonelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_zonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_asb
end interface mld_aggrmat_asb
interface mld_aggrmat_nosmth_asb
subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_zonelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_zonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_nosmth_asb
end interface mld_aggrmat_nosmth_asb
interface mld_aggrmat_smth_asb
subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_zonelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_zonelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_smth_asb
end interface mld_aggrmat_smth_asb
end module mld_z_inner_mod
mlprec/mld_z_jac_smoother.f90
+17 -8
View File
@@ -90,7 +90,7 @@ contains
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_jac_smoother_apply'
character(len=20) :: name='z_jac_smoother_apply'
call psb_erractionsave(err_act)
@@ -142,7 +142,8 @@ contains
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in sub_aply Jacobi Sweeps = 1')
call psb_errpush(psb_err_internal_error_,&
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
@@ -243,7 +244,7 @@ contains
integer :: n_row,n_col, nrow_a, nztota, nzeros
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_jac_smoother_bld', ch_err
character(len=20) :: name='z_jac_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
@@ -271,7 +272,15 @@ contains
if (info == psb_success_) &
& call sm%sv%build(a,desc_a,upd,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4')
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='clip & psb_spcnv csr 4')
goto 9999
end if
call sm%sv%build(a,desc_a,upd,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='solver build')
goto 9999
end if
nzeros = sm%nd%get_nzeros()
@@ -306,7 +315,7 @@ contains
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_jac_smoother_seti'
character(len=20) :: name='z_jac_smoother_seti'
info = psb_success_
call psb_erractionsave(err_act)
@@ -347,7 +356,7 @@ contains
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_jac_smoother_setc'
character(len=20) :: name='z_jac_smoother_setc'
info = psb_success_
call psb_erractionsave(err_act)
@@ -385,7 +394,7 @@ contains
real(psb_dpk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_jac_smoother_setr'
character(len=20) :: name='z_jac_smoother_setr'
call psb_erractionsave(err_act)
info = psb_success_
@@ -420,7 +429,7 @@ contains
class(mld_z_jac_smoother_type), intent(inout) :: sm
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_jac_smoother_free'
character(len=20) :: name='z_jac_smoother_free'
call psb_erractionsave(err_act)
info = psb_success_
mlprec/mld_z_move_alloc_mod.f90
+103
View File
@@ -0,0 +1,103 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ 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_move_alloc_mod.f90
!
! Module: mld_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_z_move_alloc_mod
use mld_z_prec_type
interface mld_move_alloc
module procedure mld_zonelev_prec_move_alloc,&
& mld_zprec_move_alloc
end interface
contains
subroutine mld_zonelev_prec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_zonelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call mld_precfree(b,info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_zonelev_prec_move_alloc
subroutine mld_zprec_move_alloc(a, b,info)
use psb_sparse_mod
implicit none
type(mld_zprec_type), intent(inout) :: a
type(mld_zprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i,isz
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, isz
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_zprec_move_alloc
end module mld_z_move_alloc_mod

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