diff --git a/config/pac.m4 b/config/pac.m4 index 87753bcf..64b43956 100644 --- a/config/pac.m4 +++ b/config/pac.m4 @@ -774,9 +774,9 @@ dnl @author Salvatore Filippone 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 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 diff --git a/configure b/configure index 651911f6..3c1d0989 100755 --- a/configure +++ b/configure @@ -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" diff --git a/mlprec/Makefile b/mlprec/Makefile index cb97fc20..82fabf81 100644 --- a/mlprec/Makefile +++ b/mlprec/Makefile @@ -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) + diff --git a/mlprec/mld_base_prec_type.f90 b/mlprec/mld_base_prec_type.f90 index 79352642..4eddbc7c 100644 --- a/mlprec/mld_base_prec_type.f90 +++ b/mlprec/mld_base_prec_type.f90 @@ -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 diff --git a/mlprec/mld_c_as_smoother.f90 b/mlprec/mld_c_as_smoother.f90 index 89bd20e6..ae6e2261 100644 --- a/mlprec/mld_c_as_smoother.f90 +++ b/mlprec/mld_c_as_smoother.f90 @@ -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 diff --git a/mlprec/mld_c_id_solver.f90 b/mlprec/mld_c_id_solver.f90 new file mode 100644 index 00000000..1611a96b --- /dev/null +++ b/mlprec/mld_c_id_solver.f90 @@ -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 diff --git a/mlprec/mld_c_ilu_solver.f90 b/mlprec/mld_c_ilu_solver.f90 index 34d600f1..16d8e1aa 100644 --- a/mlprec/mld_c_ilu_solver.f90 +++ b/mlprec/mld_c_ilu_solver.f90 @@ -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 diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 new file mode 100644 index 00000000..b54a93c7 --- /dev/null +++ b/mlprec/mld_c_inner_mod.f90 @@ -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 diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index ff413321..3ed60594 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -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_ diff --git a/mlprec/mld_c_move_alloc_mod.f90 b/mlprec/mld_c_move_alloc_mod.f90 new file mode 100644 index 00000000..67394319 --- /dev/null +++ b/mlprec/mld_c_move_alloc_mod.f90 @@ -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 diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 new file mode 100644 index 00000000..4bb5a392 --- /dev/null +++ b/mlprec/mld_c_prec_mod.f90 @@ -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 diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 86013294..d9deae8d 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -133,7 +133,7 @@ module mld_c_prec_type ! integer, allocatable :: iprcparm(:) ! real(psb_Tpk_), allocatable :: rprcparm(:) ! integer, allocatable :: perm(:), invperm(:) - ! end type mld_sbaseprec_type + ! end type mld_cbaseprec_type ! ! Note that IntrType denotes the real or complex data type, and psb_Tpk denotes ! the kind of the real or complex type, according to the real/complex, single/double @@ -177,6 +177,8 @@ module mld_c_prec_type type mld_c_base_solver_type contains + procedure, pass(sv) :: check => c_base_solver_check + procedure, pass(sv) :: dump => c_base_solver_dmp procedure, pass(sv) :: build => c_base_solver_bld procedure, pass(sv) :: apply => c_base_solver_apply procedure, pass(sv) :: free => c_base_solver_free @@ -185,13 +187,15 @@ module mld_c_prec_type procedure, pass(sv) :: setr => c_base_solver_setr generic, public :: set => seti, setc, setr procedure, pass(sv) :: default => c_base_solver_default - procedure, pass(sv) :: descr => c_base_solver_descr - procedure, pass(sv) :: sizeof => c_base_solver_sizeof + procedure, pass(sv) :: descr => c_base_solver_descr + procedure, pass(sv) :: sizeof => c_base_solver_sizeof end type mld_c_base_solver_type type mld_c_base_smoother_type class(mld_c_base_solver_type), allocatable :: sv contains + procedure, pass(sm) :: check => c_base_smoother_check + procedure, pass(sm) :: dump => c_base_smoother_dmp procedure, pass(sm) :: build => c_base_smoother_bld procedure, pass(sm) :: apply => c_base_smoother_apply procedure, pass(sm) :: free => c_base_smoother_free @@ -200,27 +204,23 @@ module mld_c_prec_type procedure, pass(sm) :: setr => c_base_smoother_setr generic, public :: set => seti, setc, setr procedure, pass(sm) :: default => c_base_smoother_default - procedure, pass(sm) :: descr => c_base_smoother_descr - procedure, pass(sm) :: sizeof => c_base_smoother_sizeof + procedure, pass(sm) :: descr => c_base_smoother_descr + procedure, pass(sm) :: sizeof => c_base_smoother_sizeof end type mld_c_base_smoother_type - type, extends(psb_c_base_prec_type) :: mld_cbaseprec_type - integer, allocatable :: iprcparm(:) - real(psb_spk_), allocatable :: rprcparm(:) - end type mld_cbaseprec_type - type mld_conelev_type class(mld_c_base_smoother_type), allocatable :: sm - integer :: sweeps, sweeps_pre, sweeps_post - type(mld_cbaseprec_type) :: prec - integer, allocatable :: iprcparm(:) - real(psb_spk_), allocatable :: rprcparm(:) - type(psb_cspmat_type) :: ac + type(mld_sml_parms) :: parms + type(psb_cspmat_type) :: ac type(psb_desc_type) :: desc_ac - type(psb_cspmat_type), pointer :: base_a => null() + type(psb_cspmat_type), pointer :: base_a => null() type(psb_desc_type), pointer :: base_desc => null() type(psb_clinmap_type) :: map contains + procedure, pass(lv) :: descr => c_base_onelev_descr + procedure, pass(lv) :: default => c_base_onelev_default + procedure, pass(lv) :: check => c_base_onelev_check + procedure, pass(lv) :: dump => c_base_onelev_dump procedure, pass(lv) :: seti => c_base_onelev_seti procedure, pass(lv) :: setr => c_base_onelev_setr procedure, pass(lv) :: setc => c_base_onelev_setc @@ -233,18 +233,25 @@ module mld_c_prec_type contains procedure, pass(prec) :: c_apply2v => mld_c_apply2v procedure, pass(prec) :: c_apply1v => mld_c_apply1v + procedure, pass(prec) :: dump => mld_c_dump end type mld_cprec_type private :: c_base_solver_bld, c_base_solver_apply, & & c_base_solver_free, c_base_solver_seti, & & c_base_solver_setc, c_base_solver_setr, & & c_base_solver_descr, c_base_solver_sizeof, & - & c_base_solver_default, & + & c_base_solver_default, c_base_solver_check,& + & c_base_solver_dmp, & & c_base_smoother_bld, c_base_smoother_apply, & & c_base_smoother_free, c_base_smoother_seti, & & c_base_smoother_setc, c_base_smoother_setr,& & c_base_smoother_descr, c_base_smoother_sizeof, & - & c_base_smoother_default + & c_base_smoother_default, c_base_smoother_check, & + & c_base_smoother_dmp, & + & c_base_onelev_seti, c_base_onelev_setc, & + & c_base_onelev_setr, c_base_onelev_check, & + & c_base_onelev_default, c_base_onelev_dump, & + & c_base_onelev_descr ! @@ -253,11 +260,7 @@ module mld_c_prec_type ! interface mld_precfree - module procedure mld_cbase_precfree, mld_c_onelev_precfree, mld_cprec_free - end interface - - interface mld_nullify_baseprec - module procedure mld_nullify_cbaseprec + module procedure mld_c_onelev_precfree, mld_cprec_free end interface interface mld_nullify_onelevprec @@ -269,7 +272,7 @@ module mld_c_prec_type end interface interface mld_sizeof - module procedure mld_cprec_sizeof, mld_cbaseprec_sizeof, mld_c_onelev_prec_sizeof + module procedure mld_cprec_sizeof, mld_c_onelev_prec_sizeof end interface interface mld_precaply @@ -314,40 +317,6 @@ contains end if end function mld_cprec_sizeof - function mld_cbaseprec_sizeof(prec) result(val) - implicit none - type(mld_cbaseprec_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_sp * size(prec%rprcparm) -!!$ if (allocated(prec%d)) val = val + psb_sizeof_sp * size(prec%d) -!!$ if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) -!!$ if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) -!!$ val = val + psb_sizeof(prec%desc_data) -!!$ if (allocated(prec%av)) then -!!$ do i=1,size(prec%av) -!!$ val = val + psb_sizeof(prec%av(i)) -!!$ end do -!!$ end if - - - end function mld_cbaseprec_sizeof function mld_c_onelev_prec_sizeof(prec) result(val) implicit none @@ -355,14 +324,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_sp * size(prec%rprcparm) + val = 0 val = val + psb_sizeof(prec%desc_ac) val = val + psb_sizeof(prec%ac) val = val + psb_sizeof(prec%map) @@ -422,10 +384,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 @@ -445,16 +415,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 ! @@ -464,8 +424,7 @@ contains ! ilev=2 - call mld_ml_alg_descr(iout_,ilev,p%precv(ilev)%iprcparm, info,& - & rprcparm=p%precv(ilev)%rprcparm) + call p%precv(ilev)%parms%descr(iout_,info) ! ! Coarse matrices are different at levels 2,...,nlev-1, hence related @@ -473,24 +432,21 @@ contains ! write(iout_,*) do ilev = 2, nlev-1 - call mld_ml_level_descr(iout_,ilev,p%precv(ilev)%iprcparm,& - & p%precv(ilev)%map%naggr,info,& - & rprcparm=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 ! + ! 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,& - & rprcparm=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 @@ -517,58 +473,66 @@ contains ! info - integer, output. ! error code. ! - subroutine mld_cbase_precfree(p,info) - implicit none - type(mld_cbaseprec_type), intent(inout) :: p + + subroutine c_base_onelev_descr(lv,info,iout,coarse) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_conelev_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_c_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%desc_data%matrix_data)) & -!!$ & call psb_cdfree(p%desc_data,info) -!!$ - 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_cslu_free(p%iprcparm(mld_slu_ptr_),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) - end subroutine mld_cbase_precfree + if (allocated(lv%sm)) & + & call lv%sm%descr(info,iout=iout_) + + 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_base_onelev_descr subroutine mld_c_onelev_precfree(p,info) use psb_sparse_mod @@ -581,16 +545,14 @@ contains info = psb_success_ ! Actually we might just deallocate the top level array, except - ! for the inner UMFPACK or SLU stuff - call mld_precfree(p%prec,info) + ! for the inner UMFPACK or SLU stuff. + ! We really need FINALs. + call p%sm%free(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. @@ -605,14 +567,6 @@ contains call mld_nullify_onelevprec(p) end subroutine mld_c_onelev_precfree - subroutine mld_nullify_cbaseprec(p) - implicit none - - type(mld_cbaseprec_type), intent(inout) :: p - - - end subroutine mld_nullify_cbaseprec - subroutine mld_nullify_c_onelevprec(p) implicit none @@ -677,7 +631,7 @@ contains integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_apply' + character(len=20) :: name='c_base_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ @@ -704,6 +658,44 @@ contains end subroutine c_base_smoother_apply + subroutine c_base_smoother_check(sm,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_c_base_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='c_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 c_base_smoother_check + + subroutine c_base_smoother_seti(sm,what,val,info) use psb_sparse_mod @@ -716,7 +708,7 @@ contains integer, intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_seti' + character(len=20) :: name='c_base_smoother_seti' call psb_erractionsave(err_act) info = psb_success_ @@ -749,7 +741,7 @@ contains character(len=*), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_setc' + character(len=20) :: name='c_base_smoother_setc' call psb_erractionsave(err_act) @@ -784,7 +776,7 @@ contains real(psb_spk_), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_setr' + character(len=20) :: name='c_base_smoother_setr' call psb_erractionsave(err_act) @@ -821,7 +813,7 @@ contains character, intent(in) :: upd integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_bld' + character(len=20) :: name='c_base_smoother_bld' call psb_erractionsave(err_act) @@ -857,7 +849,7 @@ contains class(mld_c_base_smoother_type), intent(inout) :: sm integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_free' + character(len=20) :: name='c_base_smoother_free' call psb_erractionsave(err_act) info = psb_success_ @@ -952,6 +944,8 @@ contains class(mld_c_base_smoother_type), intent(inout) :: sm ! Do nothing for base version + if (allocated(sm%sv)) call sm%sv%default() + return end subroutine c_base_smoother_default @@ -969,11 +963,11 @@ contains integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_apply' + character(len=20) :: name='c_base_solver_apply' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1004,11 +998,11 @@ contains integer, intent(out) :: info type(psb_cspmat_type), intent(in), target, optional :: b Integer :: err_act - character(len=20) :: name='d_base_solver_bld' + character(len=20) :: name='c_base_solver_bld' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1025,6 +1019,36 @@ contains end subroutine c_base_solver_bld + subroutine c_base_solver_check(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_c_base_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='c_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 c_base_solver_check + subroutine c_base_solver_seti(sv,what,val,info) use psb_sparse_mod @@ -1037,23 +1061,11 @@ contains integer, intent(in) :: val 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 + character(len=20) :: name='c_base_solver_seti' + + ! Correct action here is doing nothing. + info = 0 + return end subroutine c_base_solver_seti @@ -1068,14 +1080,18 @@ contains integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_base_solver_setc' + Integer :: err_act, ival + character(len=20) :: name='c_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 @@ -1101,23 +1117,12 @@ contains real(psb_spk_), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_setr' + character(len=20) :: name='c_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 c_base_solver_setr @@ -1131,11 +1136,11 @@ contains class(mld_c_base_solver_type), intent(inout) :: sv integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_free' + character(len=20) :: name='c_base_solver_free' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1171,7 +1176,7 @@ contains call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1218,7 +1223,7 @@ contains character(len=1), optional :: trans complex(psb_spk_),intent(inout), optional, target :: work(:) Integer :: err_act - character(len=20) :: name='s_prec_apply' + character(len=20) :: name='c_prec_apply' call psb_erractionsave(err_act) @@ -1226,7 +1231,7 @@ contains type is (mld_cprec_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 @@ -1260,7 +1265,7 @@ contains type is (mld_cprec_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 @@ -1278,6 +1283,82 @@ contains end subroutine mld_c_apply1v + subroutine c_base_onelev_check(lv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_conelev_type), intent(inout) :: lv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='c_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 c_base_onelev_check + + + subroutine c_base_onelev_default(lv) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_conelev_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 = szero + lv%parms%aggr_thresh = szero + + if (allocated(lv%sm)) call lv%sm%default() + + return + + end subroutine c_base_onelev_default + + subroutine c_base_onelev_seti(lv,what,val,info) use psb_sparse_mod @@ -1290,20 +1371,51 @@ contains integer, intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_onelev_seti' + character(len=20) :: name='c_base_onelev_seti' call psb_erractionsave(err_act) 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) @@ -1334,15 +1446,16 @@ contains character(len=*), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_onelev_setc' + character(len=20) :: name='c_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) @@ -1375,11 +1488,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 @@ -1393,5 +1516,169 @@ contains return end subroutine c_base_onelev_setr + subroutine mld_c_dump(prec,info,istart,iend,prefix,head,ac,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_cprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, intent(in), optional :: istart, iend + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver,ac + 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 + + iln = size(prec%precv) + if (present(istart)) then + il1 = max(1,istart) + else + il1 = 2 + end if + if (present(iend)) then + iln = min(iln, iend) + end if + + do lev=il1, iln + call prec%precv(lev)%dump(lev,info,prefix=prefix,head=head,& + & ac=ac,smoother=smoother,solver=solver) + end do + + end subroutine mld_c_dump + + subroutine c_base_onelev_dump(lv,level,info,prefix,head,ac,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_conelev_type), intent(in) :: lv + integer, intent(in) :: level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: ac, 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 :: ac_ + ! len of prefix_ + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_lev_c" + end if + + if (associated(lv%base_desc)) then + icontxt = psb_cd_get_context(lv%base_desc) + call psb_info(icontxt,iam,np) + else + icontxt = -1 + iam = -1 + end if + if (present(ac)) then + ac_ = ac + else + ac_ = .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 (level >= 2) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + write(0,*) 'Filename ',fname + if (ac_) call lv%ac%print(fname,head=head) + end if + if (allocated(lv%sm)) & + & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver) + + end subroutine c_base_onelev_dump + + subroutine c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_c_base_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_d" + 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 + + ! At base level do nothing for the smoother + if (allocated(sm%sv)) & + & call sm%sv%dump(ictxt,level,info,solver=solver) + + end subroutine c_base_smoother_dmp + + subroutine c_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + use psb_sparse_mod + implicit none + class(mld_c_base_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 + + ! At base level do nothing for the solver + + end subroutine c_base_solver_dmp + + end module mld_c_prec_type diff --git a/mlprec/mld_c_slu_solver.f90 b/mlprec/mld_c_slu_solver.f90 new file mode 100644 index 00000000..a33f4dac --- /dev/null +++ b/mlprec/mld_c_slu_solver.f90 @@ -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 diff --git a/mlprec/mld_caggrmap_bld.f90 b/mlprec/mld_caggrmap_bld.f90 index 6761d480..f6c2e33c 100644 --- a/mlprec/mld_caggrmap_bld.f90 +++ b/mlprec/mld_caggrmap_bld.f90 @@ -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 diff --git a/mlprec/mld_caggrmat_asb.f90 b/mlprec/mld_caggrmat_asb.f90 index 3a5b3c8a..eca6100f 100644 --- a/mlprec/mld_caggrmat_asb.f90 +++ b/mlprec/mld_caggrmat_asb.f90 @@ -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) diff --git a/mlprec/mld_caggrmat_nosmth_asb.F90 b/mlprec/mld_caggrmat_nosmth_asb.F90 index c3c345bc..e588118c 100644 --- a/mlprec/mld_caggrmat_nosmth_asb.F90 +++ b/mlprec/mld_caggrmat_nosmth_asb.F90 @@ -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) diff --git a/mlprec/mld_caggrmat_smth_asb.F90 b/mlprec/mld_caggrmat_smth_asb.F90 index 758c7cd9..b7ff790b 100644 --- a/mlprec/mld_caggrmat_smth_asb.F90 +++ b/mlprec/mld_caggrmat_smth_asb.F90 @@ -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_) diff --git a/mlprec/mld_ccoarse_bld.f90 b/mlprec/mld_ccoarse_bld.f90 index f139cd54..811e682d 100644 --- a/mlprec/mld_ccoarse_bld.f90 +++ b/mlprec/mld_ccoarse_bld.f90 @@ -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 diff --git a/mlprec/mld_cilu0_fact.f90 b/mlprec/mld_cilu0_fact.f90 index d9d0db08..6346035d 100644 --- a/mlprec/mld_cilu0_fact.f90 +++ b/mlprec/mld_cilu0_fact.f90 @@ -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 diff --git a/mlprec/mld_ciluk_fact.f90 b/mlprec/mld_ciluk_fact.f90 index b413a0d2..b0e48f37 100644 --- a/mlprec/mld_ciluk_fact.f90 +++ b/mlprec/mld_ciluk_fact.f90 @@ -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 diff --git a/mlprec/mld_cilut_fact.f90 b/mlprec/mld_cilut_fact.f90 index 99d13f01..10cd7005 100644 --- a/mlprec/mld_cilut_fact.f90 +++ b/mlprec/mld_cilut_fact.f90 @@ -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 diff --git a/mlprec/mld_cmlprec_aply.f90 b/mlprec/mld_cmlprec_aply.f90 index ad9665ab..187745f1 100644 --- a/mlprec/mld_cmlprec_aply.f90 +++ b/mlprec/mld_cmlprec_aply.f90 @@ -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 diff --git a/mlprec/mld_cmlprec_bld.f90 b/mlprec/mld_cmlprec_bld.f90 index eccad4ef..b1bd18cf 100644 --- a/mlprec/mld_cmlprec_bld.f90 +++ b/mlprec/mld_cmlprec_bld.f90 @@ -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 diff --git a/mlprec/mld_cprecaply.f90 b/mlprec/mld_cprecaply.f90 index d37ba04d..a23e0c90 100644 --- a/mlprec/mld_cprecaply.f90 +++ b/mlprec/mld_cprecaply.f90 @@ -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 diff --git a/mlprec/mld_cprecbld.f90 b/mlprec/mld_cprecbld.f90 index 665994e5..4c13dda2 100644 --- a/mlprec/mld_cprecbld.f90 +++ b/mlprec/mld_cprecbld.f90 @@ -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 diff --git a/mlprec/mld_cprecinit.F90 b/mlprec/mld_cprecinit.F90 index c8e4a567..12ea8453 100644 --- a/mlprec/mld_cprecinit.F90 +++ b/mlprec/mld_cprecinit.F90 @@ -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,'"' diff --git a/mlprec/mld_cprecset.F90 b/mlprec/mld_cprecset.F90 index 1b2cd465..1246faeb 100644 --- a/mlprec/mld_cprecset.F90 +++ b/mlprec/mld_cprecset.F90 @@ -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' diff --git a/mlprec/mld_cslu_bld.f90 b/mlprec/mld_cslu_bld.f90 index 4139ff09..2cedec9f 100644 --- a/mlprec/mld_cslu_bld.f90 +++ b/mlprec/mld_cslu_bld.f90 @@ -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 diff --git a/mlprec/mld_cslu_interface.c b/mlprec/mld_cslu_interface.c index d28fd754..cb764aff 100644 --- a/mlprec/mld_cslu_interface.c +++ b/mlprec/mld_cslu_interface.c @@ -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 } diff --git a/mlprec/mld_cslud_bld.f90 b/mlprec/mld_cslud_bld.f90 index f7528aff..cfd4c6af 100644 --- a/mlprec/mld_cslud_bld.f90 +++ b/mlprec/mld_cslud_bld.f90 @@ -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 diff --git a/mlprec/mld_csp_renum.f90 b/mlprec/mld_csp_renum.f90 index 66ae6018..f33b382a 100644 --- a/mlprec/mld_csp_renum.f90 +++ b/mlprec/mld_csp_renum.f90 @@ -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 diff --git a/mlprec/mld_cumf_bld.f90 b/mlprec/mld_cumf_bld.f90 index 94cd2dd4..52f7fc6d 100644 --- a/mlprec/mld_cumf_bld.f90 +++ b/mlprec/mld_cumf_bld.f90 @@ -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 diff --git a/mlprec/mld_d_as_smoother.f90 b/mlprec/mld_d_as_smoother.f90 index 0cadff7c..42c657f0 100644 --- a/mlprec/mld_d_as_smoother.f90 +++ b/mlprec/mld_d_as_smoother.f90 @@ -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) diff --git a/mlprec/mld_d_id_solver.f90 b/mlprec/mld_d_id_solver.f90 new file mode 100644 index 00000000..a437ff59 --- /dev/null +++ b/mlprec/mld_d_id_solver.f90 @@ -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 diff --git a/mlprec/mld_d_ilu_solver.f90 b/mlprec/mld_d_ilu_solver.f90 index 5540b42d..f39ca11a 100644 --- a/mlprec/mld_d_ilu_solver.f90 +++ b/mlprec/mld_d_ilu_solver.f90 @@ -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 diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 new file mode 100644 index 00000000..ed20fc8b --- /dev/null +++ b/mlprec/mld_d_inner_mod.f90 @@ -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 diff --git a/mlprec/mld_d_move_alloc_mod.f90 b/mlprec/mld_d_move_alloc_mod.f90 new file mode 100644 index 00000000..47e52f28 --- /dev/null +++ b/mlprec/mld_d_move_alloc_mod.f90 @@ -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 diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 new file mode 100644 index 00000000..74a4b361 --- /dev/null +++ b/mlprec/mld_d_prec_mod.f90 @@ -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 diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index fd7c5db7..b6294b84 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -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 diff --git a/mlprec/mld_d_slu_solver.f90 b/mlprec/mld_d_slu_solver.f90 new file mode 100644 index 00000000..b47a9487 --- /dev/null +++ b/mlprec/mld_d_slu_solver.f90 @@ -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 diff --git a/mlprec/mld_d_sludist_solver.f90 b/mlprec/mld_d_sludist_solver.f90 new file mode 100644 index 00000000..f3f183f4 --- /dev/null +++ b/mlprec/mld_d_sludist_solver.f90 @@ -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 diff --git a/mlprec/mld_d_umf_solver.f90 b/mlprec/mld_d_umf_solver.f90 index 71b51a58..05925e44 100644 --- a/mlprec/mld_d_umf_solver.f90 +++ b/mlprec/mld_d_umf_solver.f90 @@ -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 diff --git a/mlprec/mld_daggrmap_bld.f90 b/mlprec/mld_daggrmap_bld.f90 index 8a430d87..5e75b336 100644 --- a/mlprec/mld_daggrmap_bld.f90 +++ b/mlprec/mld_daggrmap_bld.f90 @@ -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 diff --git a/mlprec/mld_daggrmat_asb.f90 b/mlprec/mld_daggrmat_asb.f90 index dda70c2e..17c73d65 100644 --- a/mlprec/mld_daggrmat_asb.f90 +++ b/mlprec/mld_daggrmat_asb.f90 @@ -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) diff --git a/mlprec/mld_daggrmat_minnrg_asb.F90 b/mlprec/mld_daggrmat_minnrg_asb.F90 index e10f67af..3f4151d4 100644 --- a/mlprec/mld_daggrmat_minnrg_asb.F90 +++ b/mlprec/mld_daggrmat_minnrg_asb.F90 @@ -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_) !!$ diff --git a/mlprec/mld_daggrmat_nosmth_asb.F90 b/mlprec/mld_daggrmat_nosmth_asb.F90 index 272f7d70..323d97e4 100644 --- a/mlprec/mld_daggrmat_nosmth_asb.F90 +++ b/mlprec/mld_daggrmat_nosmth_asb.F90 @@ -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) diff --git a/mlprec/mld_daggrmat_smth_asb.F90 b/mlprec/mld_daggrmat_smth_asb.F90 index 6cca52a0..db76b153 100644 --- a/mlprec/mld_daggrmat_smth_asb.F90 +++ b/mlprec/mld_daggrmat_smth_asb.F90 @@ -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_) diff --git a/mlprec/mld_dcoarse_bld.f90 b/mlprec/mld_dcoarse_bld.f90 index 8085889a..a0b22da5 100644 --- a/mlprec/mld_dcoarse_bld.f90 +++ b/mlprec/mld_dcoarse_bld.f90 @@ -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 diff --git a/mlprec/mld_dilu0_fact.f90 b/mlprec/mld_dilu0_fact.f90 index 56bfe51c..fcf89e6d 100644 --- a/mlprec/mld_dilu0_fact.f90 +++ b/mlprec/mld_dilu0_fact.f90 @@ -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 diff --git a/mlprec/mld_diluk_fact.f90 b/mlprec/mld_diluk_fact.f90 index 5ade070f..feee2bd2 100644 --- a/mlprec/mld_diluk_fact.f90 +++ b/mlprec/mld_diluk_fact.f90 @@ -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 diff --git a/mlprec/mld_dilut_fact.f90 b/mlprec/mld_dilut_fact.f90 index 50eafa8a..919a4c0a 100644 --- a/mlprec/mld_dilut_fact.f90 +++ b/mlprec/mld_dilut_fact.f90 @@ -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 diff --git a/mlprec/mld_dmlprec_aply.f90 b/mlprec/mld_dmlprec_aply.f90 index d44f25e3..b952e6d7 100644 --- a/mlprec/mld_dmlprec_aply.f90 +++ b/mlprec/mld_dmlprec_aply.f90 @@ -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 diff --git a/mlprec/mld_dmlprec_bld.f90 b/mlprec/mld_dmlprec_bld.f90 index 79650b16..8925f952 100644 --- a/mlprec/mld_dmlprec_bld.f90 +++ b/mlprec/mld_dmlprec_bld.f90 @@ -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= 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 diff --git a/mlprec/mld_dprecaply.f90 b/mlprec/mld_dprecaply.f90 index fe23921a..8cac9a9f 100644 --- a/mlprec/mld_dprecaply.f90 +++ b/mlprec/mld_dprecaply.f90 @@ -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 diff --git a/mlprec/mld_dprecbld.f90 b/mlprec/mld_dprecbld.f90 index a73d7518..03bdb015 100644 --- a/mlprec/mld_dprecbld.f90 +++ b/mlprec/mld_dprecbld.f90 @@ -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 diff --git a/mlprec/mld_dprecinit.F90 b/mlprec/mld_dprecinit.F90 index 6ebf6d36..5b329340 100644 --- a/mlprec/mld_dprecinit.F90 +++ b/mlprec/mld_dprecinit.F90 @@ -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_ diff --git a/mlprec/mld_dprecset.F90 b/mlprec/mld_dprecset.F90 index ef2264cf..d0a4d897 100644 --- a/mlprec/mld_dprecset.F90 +++ b/mlprec/mld_dprecset.F90 @@ -79,12 +79,18 @@ subroutine mld_dprecseti(p,what,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_dprecseti + use mld_d_prec_mod, mld_protect_name => mld_dprecseti use mld_d_jac_smoother use mld_d_as_smoother use mld_d_diag_solver use mld_d_ilu_solver - + use mld_d_id_solver +#if defined(HAVE_UMF_) + use mld_d_umf_solver +#endif +#if defined(HAVE_SLU_) + use mld_d_slu_solver +#endif implicit none @@ -132,56 +138,43 @@ subroutine mld_dprecseti(p,what,val,info,ilev) ! select case(what) case(mld_smoother_type_) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_smoother_sweeps_) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + 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_) - p%precv(ilev_)%iprcparm(what) = val + & 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_) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_smoother_sweeps_) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + 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_) - 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_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& + & mld_sub_restr_,mld_sub_prol_, & + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & 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' @@ -190,16 +183,32 @@ subroutine mld_dprecseti(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_UMF_) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif 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 @@ -207,17 +216,15 @@ subroutine mld_dprecseti(p,what,val,info,ilev) info = -2 return end if - p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 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 @@ -231,118 +238,94 @@ subroutine mld_dprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) + 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_)%iprcparm(what) = val - 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) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val - p%precv(ilev_)%prec%iprcparm(what) = val + call p%precv(ilev_)%set(what,val,info) end do case(mld_smoother_type_) - do ilev_=1,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 - p%precv(ilev_)%prec%iprcparm(what) = val + 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_sweeps_pre_,mld_smoother_sweeps_post_,& & mld_smoother_pos_,mld_aggr_omega_alg_,& & mld_aggr_eig_,mld_aggr_filter_) do ilev_=1,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 + 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_UMF_) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif 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 - case(mld_jac_) - p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_ - p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ - 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) then - p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val - p%precv(nlev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(nlev_)%iprcparm(mld_smoother_sweeps_post_) = val - p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_post_) = val + 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 @@ -350,30 +333,220 @@ subroutine mld_dprecseti(p,what,val,info,ilev) endif +contains + + subroutine onelev_set_smoother(level,val,info) + type(mld_donelev_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_d_base_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_d_base_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_d_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_base_smoother_type ::& + & level%sm, stat=info) + if (info ==0) allocate(mld_d_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_d_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_d_jac_smoother_type :: & + & level%sm, stat=info) + if (info == 0) allocate(mld_d_diag_solver_type :: & + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_d_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_d_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_d_jac_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_d_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_d_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_d_as_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_d_as_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_d_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_as_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_d_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_donelev_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_d_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_d_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_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_d_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_d_diag_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_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_d_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_d_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_ilu_solver_type :: level%sm%sv, stat=info) + endif +#ifdef HAVE_UMF_ + case (mld_umf_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_umf_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_d_umf_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_umf_solver_type :: level%sm%sv, stat=info) + endif +#endif +#ifdef HAVE_SLU_ + case (mld_slu_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_d_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_d_slu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_d_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_dprecseti -subroutine mld_dprecsetsm(p,what,val,info,ilev) +subroutine mld_dprecsetsm(p,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_dprecsetsm - use mld_d_jac_smoother - use mld_d_as_smoother - use mld_d_diag_solver - use mld_d_ilu_solver - + use mld_d_prec_mod, mld_protect_name => mld_dprecsetsm implicit none ! Arguments 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 ! Local variables - integer :: ilev_, nlev_ + integer :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -388,8 +561,12 @@ subroutine mld_dprecsetsm(p,what,val,info,ilev) 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 @@ -397,271 +574,40 @@ subroutine mld_dprecsetsm(p,what,val,info,ilev) write(0,*) 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. -!!$ ! -!!$ if (present(ilev)) then -!!$ -!!$ if (ilev_ == 1) then -!!$ ! -!!$ ! Rules for fine level are slightly different. -!!$ ! -!!$ select case(what) -!!$ case(mld_smoother_type_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_smoother_sweeps_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ 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_,& -!!$ & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ else if (ilev_ > 1) then -!!$ select case(what) -!!$ case(mld_smoother_type_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_smoother_sweeps_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ 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_,& -!!$ & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_) -!!$ 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 -!!$ 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 -!!$ case(mld_coarse_solve_) -!!$ if (ilev_ /= nlev_) then -!!$ write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' -!!$ info = -2 -!!$ return -!!$ 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_ -!!$ 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_sweeps_) -!!$ 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_smoother_sweeps_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ 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 -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ endif -!!$ -!!$ else if (.not.present(ilev)) then -!!$ ! -!!$ ! ilev not specified: set preconditioner parameters at all the appropriate -!!$ ! levels -!!$ ! -!!$ select case(what) -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ do ilev_=1,max(1,nlev_-1) -!!$ 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 -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ case(mld_smoother_sweeps_) -!!$ do ilev_=1,max(1,nlev_-1) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ -!!$ case(mld_smoother_type_) -!!$ do ilev_=1,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 -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& -!!$ & 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_ -!!$ 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 -!!$ 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 -!!$ 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 -!!$ 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 -!!$ case(mld_jac_) -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ 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 -!!$ -!!$ 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) then -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val -!!$ p%precv(nlev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(nlev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_post_) = val -!!$ 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 -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ 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_dprecsetsm -subroutine mld_dprecsetsv(p,what,val,info,ilev) +subroutine mld_dprecsetsv(p,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_dprecsetsv - use mld_d_diag_solver - use mld_d_ilu_solver - + use mld_d_prec_mod, mld_protect_name => mld_dprecsetsv implicit none ! Arguments 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 ! Local variables - integer :: ilev_, nlev_ + integer :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -676,258 +622,44 @@ subroutine mld_dprecsetsv(p,what,val,info,ilev) 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 - 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. - ! -!!$ if (present(ilev)) then -!!$ -!!$ if (ilev_ == 1) then -!!$ ! -!!$ ! Rules for fine level are slightly different. -!!$ ! -!!$ select case(what) -!!$ case(mld_smoother_type_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_smoother_sweeps_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ 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_,& -!!$ & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ else if (ilev_ > 1) then -!!$ select case(what) -!!$ case(mld_smoother_type_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_smoother_sweeps_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ 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_,& -!!$ & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_) -!!$ 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 -!!$ 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 -!!$ case(mld_coarse_solve_) -!!$ if (ilev_ /= nlev_) then -!!$ write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' -!!$ info = -2 -!!$ return -!!$ 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_ -!!$ 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_sweeps_) -!!$ 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_smoother_sweeps_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ 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 -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ endif -!!$ -!!$ else if (.not.present(ilev)) then -!!$ ! -!!$ ! ilev not specified: set preconditioner parameters at all the appropriate -!!$ ! levels -!!$ ! -!!$ select case(what) -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ do ilev_=1,max(1,nlev_-1) -!!$ 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 -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ case(mld_smoother_sweeps_) -!!$ do ilev_=1,max(1,nlev_-1) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ -!!$ case(mld_smoother_type_) -!!$ do ilev_=1,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 -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& -!!$ & 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_ -!!$ 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 -!!$ 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 -!!$ 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 -!!$ 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 -!!$ case(mld_jac_) -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ 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 -!!$ -!!$ 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) then -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val -!!$ p%precv(nlev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(nlev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_post_) = val -!!$ 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 -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ 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_dprecsetsv @@ -973,7 +705,7 @@ end subroutine mld_dprecsetsv subroutine mld_dprecsetc(p,what,string,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_dprecsetc + use mld_d_prec_mod, mld_protect_name => mld_dprecsetc implicit none @@ -1007,13 +739,6 @@ subroutine mld_dprecsetc(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) @@ -1063,7 +788,7 @@ end subroutine mld_dprecsetc subroutine mld_dprecsetr(p,what,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_dprecsetr + use mld_d_prec_mod, mld_protect_name => mld_dprecsetr implicit none @@ -1100,12 +825,6 @@ subroutine mld_dprecsetr(p,what,val,info,ilev) 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. @@ -1118,7 +837,8 @@ subroutine mld_dprecsetr(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 @@ -1127,9 +847,9 @@ subroutine mld_dprecsetr(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 @@ -1144,42 +864,20 @@ subroutine mld_dprecsetr(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' diff --git a/mlprec/mld_dslu_bld.f90 b/mlprec/mld_dslu_bld.f90 index 7b8d157b..c177d46e 100644 --- a/mlprec/mld_dslu_bld.f90 +++ b/mlprec/mld_dslu_bld.f90 @@ -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 diff --git a/mlprec/mld_dslu_interface.c b/mlprec/mld_dslu_interface.c index ec4376e6..4c02e844 100644 --- a/mlprec/mld_dslu_interface.c +++ b/mlprec/mld_dslu_interface.c @@ -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 } diff --git a/mlprec/mld_dslud_bld.f90 b/mlprec/mld_dslud_bld.f90 index a78355e9..bf337094 100644 --- a/mlprec/mld_dslud_bld.f90 +++ b/mlprec/mld_dslud_bld.f90 @@ -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/)) diff --git a/mlprec/mld_dslud_interface.c b/mlprec/mld_dslud_interface.c index eca50cb5..11463aa5 100644 --- a/mlprec/mld_dslud_interface.c +++ b/mlprec/mld_dslud_interface.c @@ -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 } diff --git a/mlprec/mld_dsp_renum.f90 b/mlprec/mld_dsp_renum.f90 index c307c3dc..3923c956 100644 --- a/mlprec/mld_dsp_renum.f90 +++ b/mlprec/mld_dsp_renum.f90 @@ -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 diff --git a/mlprec/mld_dumf_interface.c b/mlprec/mld_dumf_interface.c index e0b52d31..8f150ec9 100644 --- a/mlprec/mld_dumf_interface.c +++ b/mlprec/mld_dumf_interface.c @@ -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"); diff --git a/mlprec/mld_inner_mod.f90 b/mlprec/mld_inner_mod.f90 deleted file mode 100644 index 630ded4a..00000000 --- a/mlprec/mld_inner_mod.f90 +++ /dev/null @@ -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 diff --git a/mlprec/mld_move_alloc_mod.f90 b/mlprec/mld_move_alloc_mod.f90 deleted file mode 100644 index 04617bbc..00000000 --- a/mlprec/mld_move_alloc_mod.f90 +++ /dev/null @@ -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 diff --git a/mlprec/mld_prec_mod.f90 b/mlprec/mld_prec_mod.f90 index 28a8396d..df1e179a 100644 --- a/mlprec/mld_prec_mod.f90 +++ b/mlprec/mld_prec_mod.f90 @@ -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 diff --git a/mlprec/mld_s_as_smoother.f90 b/mlprec/mld_s_as_smoother.f90 index 54c7a4f2..9a596c38 100644 --- a/mlprec/mld_s_as_smoother.f90 +++ b/mlprec/mld_s_as_smoother.f90 @@ -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 diff --git a/mlprec/mld_s_id_solver.f90 b/mlprec/mld_s_id_solver.f90 new file mode 100644 index 00000000..fbd18fc4 --- /dev/null +++ b/mlprec/mld_s_id_solver.f90 @@ -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 diff --git a/mlprec/mld_s_ilu_solver.f90 b/mlprec/mld_s_ilu_solver.f90 index cd764e4d..3d02e9aa 100644 --- a/mlprec/mld_s_ilu_solver.f90 +++ b/mlprec/mld_s_ilu_solver.f90 @@ -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 diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 new file mode 100644 index 00000000..cd5995b7 --- /dev/null +++ b/mlprec/mld_s_inner_mod.f90 @@ -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 diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index 6c048376..11d49aaf 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -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() diff --git a/mlprec/mld_s_move_alloc_mod.f90 b/mlprec/mld_s_move_alloc_mod.f90 new file mode 100644 index 00000000..e9976624 --- /dev/null +++ b/mlprec/mld_s_move_alloc_mod.f90 @@ -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 diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 new file mode 100644 index 00000000..15a612cc --- /dev/null +++ b/mlprec/mld_s_prec_mod.f90 @@ -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 diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 3ce5aead..e3b2a5e1 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -177,6 +177,8 @@ module mld_s_prec_type type mld_s_base_solver_type contains + procedure, pass(sv) :: check => s_base_solver_check + procedure, pass(sv) :: dump => s_base_solver_dmp procedure, pass(sv) :: build => s_base_solver_bld procedure, pass(sv) :: apply => s_base_solver_apply procedure, pass(sv) :: free => s_base_solver_free @@ -185,13 +187,15 @@ module mld_s_prec_type procedure, pass(sv) :: setr => s_base_solver_setr generic, public :: set => seti, setc, setr procedure, pass(sv) :: default => s_base_solver_default - procedure, pass(sv) :: descr => s_base_solver_descr - procedure, pass(sv) :: sizeof => s_base_solver_sizeof + procedure, pass(sv) :: descr => s_base_solver_descr + procedure, pass(sv) :: sizeof => s_base_solver_sizeof end type mld_s_base_solver_type type mld_s_base_smoother_type class(mld_s_base_solver_type), allocatable :: sv contains + procedure, pass(sm) :: check => s_base_smoother_check + procedure, pass(sm) :: dump => s_base_smoother_dmp procedure, pass(sm) :: build => s_base_smoother_bld procedure, pass(sm) :: apply => s_base_smoother_apply procedure, pass(sm) :: free => s_base_smoother_free @@ -200,27 +204,23 @@ module mld_s_prec_type procedure, pass(sm) :: setr => s_base_smoother_setr generic, public :: set => seti, setc, setr procedure, pass(sm) :: default => s_base_smoother_default - procedure, pass(sm) :: descr => s_base_smoother_descr - procedure, pass(sm) :: sizeof => s_base_smoother_sizeof + procedure, pass(sm) :: descr => s_base_smoother_descr + procedure, pass(sm) :: sizeof => s_base_smoother_sizeof end type mld_s_base_smoother_type - type, extends(psb_s_base_prec_type) :: mld_sbaseprec_type - integer, allocatable :: iprcparm(:) - real(psb_spk_), allocatable :: rprcparm(:) - end type mld_sbaseprec_type - type mld_sonelev_type class(mld_s_base_smoother_type), allocatable :: sm - integer :: sweeps, sweeps_pre, sweeps_post - type(mld_sbaseprec_type) :: prec - integer, allocatable :: iprcparm(:) - real(psb_spk_), allocatable :: rprcparm(:) - type(psb_sspmat_type) :: ac + type(mld_sml_parms) :: parms + type(psb_sspmat_type) :: ac type(psb_desc_type) :: desc_ac - type(psb_sspmat_type), pointer :: base_a => null() + type(psb_sspmat_type), pointer :: base_a => null() type(psb_desc_type), pointer :: base_desc => null() type(psb_slinmap_type) :: map contains + procedure, pass(lv) :: descr => s_base_onelev_descr + procedure, pass(lv) :: default => s_base_onelev_default + procedure, pass(lv) :: check => s_base_onelev_check + procedure, pass(lv) :: dump => s_base_onelev_dump procedure, pass(lv) :: seti => s_base_onelev_seti procedure, pass(lv) :: setr => s_base_onelev_setr procedure, pass(lv) :: setc => s_base_onelev_setc @@ -233,18 +233,25 @@ module mld_s_prec_type contains procedure, pass(prec) :: s_apply2v => mld_s_apply2v procedure, pass(prec) :: s_apply1v => mld_s_apply1v + procedure, pass(prec) :: dump => mld_s_dump end type mld_sprec_type private :: s_base_solver_bld, s_base_solver_apply, & & s_base_solver_free, s_base_solver_seti, & & s_base_solver_setc, s_base_solver_setr, & & s_base_solver_descr, s_base_solver_sizeof, & - & s_base_solver_default, & + & s_base_solver_default, s_base_solver_check,& + & s_base_solver_dmp, & & s_base_smoother_bld, s_base_smoother_apply, & & s_base_smoother_free, s_base_smoother_seti, & & s_base_smoother_setc, s_base_smoother_setr,& & s_base_smoother_descr, s_base_smoother_sizeof, & - & s_base_smoother_default + & s_base_smoother_default, s_base_smoother_check, & + & s_base_smoother_dmp, & + & s_base_onelev_seti, s_base_onelev_setc, & + & s_base_onelev_setr, s_base_onelev_check, & + & s_base_onelev_default, s_base_onelev_dump, & + & s_base_onelev_descr ! @@ -253,11 +260,7 @@ module mld_s_prec_type ! interface mld_precfree - module procedure mld_sbase_precfree, mld_s_onelev_precfree, mld_sprec_free - end interface - - interface mld_nullify_baseprec - module procedure mld_nullify_sbaseprec + module procedure mld_s_onelev_precfree, mld_sprec_free end interface interface mld_nullify_onelevprec @@ -269,7 +272,7 @@ module mld_s_prec_type end interface interface mld_sizeof - module procedure mld_sprec_sizeof, mld_sbaseprec_sizeof, mld_s_onelev_prec_sizeof + module procedure mld_sprec_sizeof, mld_s_onelev_prec_sizeof end interface interface mld_precaply @@ -301,7 +304,6 @@ contains ! function mld_sprec_sizeof(prec) result(val) - use psb_sparse_mod implicit none type(mld_sprec_type), intent(in) :: prec integer(psb_long_int_k_) :: val @@ -315,40 +317,6 @@ contains end if end function mld_sprec_sizeof - function mld_sbaseprec_sizeof(prec) result(val) - implicit none - type(mld_sbaseprec_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_sp * size(prec%rprcparm) -!!$ if (allocated(prec%d)) val = val + psb_sizeof_sp * size(prec%d) -!!$ if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) -!!$ if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) -!!$ val = val + psb_sizeof(prec%desc_data) -!!$ if (allocated(prec%av)) then -!!$ do i=1,size(prec%av) -!!$ val = val + psb_sizeof(prec%av(i)) -!!$ end do -!!$ end if - - - end function mld_sbaseprec_sizeof function mld_s_onelev_prec_sizeof(prec) result(val) implicit none @@ -356,14 +324,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_sp * size(prec%rprcparm) + val = 0 val = val + psb_sizeof(prec%desc_ac) val = val + psb_sizeof(prec%ac) val = val + psb_sizeof(prec%map) @@ -423,10 +384,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 @@ -446,16 +415,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 ! @@ -465,8 +424,7 @@ contains ! ilev=2 - call mld_ml_alg_descr(iout_,ilev,p%precv(ilev)%iprcparm, info,& - & rprcparm=p%precv(ilev)%rprcparm) + call p%precv(ilev)%parms%descr(iout_,info) ! ! Coarse matrices are different at levels 2,...,nlev-1, hence related @@ -474,24 +432,21 @@ contains ! write(iout_,*) do ilev = 2, nlev-1 - call mld_ml_level_descr(iout_,ilev,p%precv(ilev)%iprcparm,& - & p%precv(ilev)%map%naggr,info,& - & rprcparm=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 ! + ! 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,& - & rprcparm=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 @@ -519,59 +474,66 @@ contains ! info - integer, output. ! error code. ! - subroutine mld_sbase_precfree(p,info) + + subroutine s_base_onelev_descr(lv,info,iout,coarse) + use psb_sparse_mod - implicit none - type(mld_sbaseprec_type), intent(inout) :: p + Implicit None + + ! Arguments + class(mld_sonelev_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_s_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_sslu_free(p%iprcparm(mld_slu_ptr_),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_) - end subroutine mld_sbase_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 s_base_onelev_descr subroutine mld_s_onelev_precfree(p,info) use psb_sparse_mod @@ -584,16 +546,14 @@ contains info = psb_success_ ! Actually we might just deallocate the top level array, except - ! for the inner UMFPACK or SLU stuff - call mld_precfree(p%prec,info) + ! for the inner UMFPACK or SLU stuff. + ! We really need FINALs. + call p%sm%free(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. @@ -608,13 +568,6 @@ contains call mld_nullify_onelevprec(p) end subroutine mld_s_onelev_precfree - subroutine mld_nullify_sbaseprec(p) - implicit none - - type(mld_sbaseprec_type), intent(inout) :: p - - - end subroutine mld_nullify_sbaseprec subroutine mld_nullify_s_onelevprec(p) implicit none @@ -680,7 +633,7 @@ contains integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_apply' + character(len=20) :: name='s_base_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ @@ -707,6 +660,44 @@ contains end subroutine s_base_smoother_apply + subroutine s_base_smoother_check(sm,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_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 s_base_smoother_check + + subroutine s_base_smoother_seti(sm,what,val,info) use psb_sparse_mod @@ -719,7 +710,7 @@ contains integer, intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_seti' + character(len=20) :: name='s_base_smoother_seti' call psb_erractionsave(err_act) info = psb_success_ @@ -752,7 +743,7 @@ contains character(len=*), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_setc' + character(len=20) :: name='s_base_smoother_setc' call psb_erractionsave(err_act) @@ -787,7 +778,7 @@ contains real(psb_spk_), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_setr' + character(len=20) :: name='s_base_smoother_setr' call psb_erractionsave(err_act) @@ -824,7 +815,7 @@ contains character, intent(in) :: upd integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_bld' + character(len=20) :: name='s_base_smoother_bld' call psb_erractionsave(err_act) @@ -860,7 +851,7 @@ contains class(mld_s_base_smoother_type), intent(inout) :: sm integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_free' + character(len=20) :: name='s_base_smoother_free' call psb_erractionsave(err_act) info = psb_success_ @@ -955,6 +946,8 @@ contains class(mld_s_base_smoother_type), intent(inout) :: sm ! Do nothing for base version + if (allocated(sm%sv)) call sm%sv%default() + return end subroutine s_base_smoother_default @@ -972,11 +965,11 @@ contains integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_apply' + character(len=20) :: name='s_base_solver_apply' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1007,11 +1000,11 @@ contains integer, intent(out) :: info type(psb_sspmat_type), intent(in), target, optional :: b Integer :: err_act - character(len=20) :: name='d_base_solver_bld' + character(len=20) :: name='s_base_solver_bld' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1028,6 +1021,36 @@ contains end subroutine s_base_solver_bld + subroutine s_base_solver_check(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_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 s_base_solver_check + subroutine s_base_solver_seti(sv,what,val,info) use psb_sparse_mod @@ -1040,23 +1063,11 @@ contains integer, intent(in) :: val 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 + character(len=20) :: name='s_base_solver_seti' + + ! Correct action here is doing nothing. + info = 0 + return end subroutine s_base_solver_seti @@ -1071,14 +1082,18 @@ contains integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_base_solver_setc' + Integer :: err_act, ival + character(len=20) :: name='s_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 @@ -1104,23 +1119,12 @@ contains real(psb_spk_), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_setr' + character(len=20) :: name='s_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 s_base_solver_setr @@ -1134,11 +1138,11 @@ contains class(mld_s_base_solver_type), intent(inout) :: sv integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_free' + character(len=20) :: name='s_base_solver_free' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1174,7 +1178,7 @@ contains call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1229,7 +1233,7 @@ contains type is (mld_sprec_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 @@ -1255,7 +1259,7 @@ contains integer, intent(out) :: info character(len=1), optional :: trans Integer :: err_act - character(len=20) :: name='d_prec_apply' + character(len=20) :: name='s_prec_apply' call psb_erractionsave(err_act) @@ -1263,7 +1267,7 @@ contains type is (mld_sprec_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 @@ -1281,6 +1285,82 @@ contains end subroutine mld_s_apply1v + subroutine s_base_onelev_check(lv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_sonelev_type), intent(inout) :: lv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_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 s_base_onelev_check + + + subroutine s_base_onelev_default(lv) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_sonelev_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 = szero + lv%parms%aggr_thresh = szero + + if (allocated(lv%sm)) call lv%sm%default() + + return + + end subroutine s_base_onelev_default + + subroutine s_base_onelev_seti(lv,what,val,info) use psb_sparse_mod @@ -1293,20 +1373,51 @@ contains integer, intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_onelev_seti' + character(len=20) :: name='s_base_onelev_seti' call psb_erractionsave(err_act) 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) @@ -1337,15 +1448,16 @@ contains character(len=*), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_onelev_setc' + character(len=20) :: name='s_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) @@ -1372,17 +1484,27 @@ contains real(psb_spk_), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_onelev_setr' + character(len=20) :: name='s_base_onelev_setr' call psb_erractionsave(err_act) 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 @@ -1396,5 +1518,169 @@ contains return end subroutine s_base_onelev_setr + subroutine mld_s_dump(prec,info,istart,iend,prefix,head,ac,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_sprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, intent(in), optional :: istart, iend + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver,ac + 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 + + iln = size(prec%precv) + if (present(istart)) then + il1 = max(1,istart) + else + il1 = 2 + end if + if (present(iend)) then + iln = min(iln, iend) + end if + + do lev=il1, iln + call prec%precv(lev)%dump(lev,info,prefix=prefix,head=head,& + & ac=ac,smoother=smoother,solver=solver) + end do + + end subroutine mld_s_dump + + + subroutine s_base_onelev_dump(lv,level,info,prefix,head,ac,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_sonelev_type), intent(in) :: lv + integer, intent(in) :: level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: ac, 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 :: ac_ + ! len of prefix_ + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_lev_d" + end if + + if (associated(lv%base_desc)) then + icontxt = psb_cd_get_context(lv%base_desc) + call psb_info(icontxt,iam,np) + else + icontxt = -1 + iam = -1 + end if + if (present(ac)) then + ac_ = ac + else + ac_ = .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 (level >= 2) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + write(0,*) 'Filename ',fname + if (ac_) call lv%ac%print(fname,head=head) + end if + if (allocated(lv%sm)) & + & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver) + + end subroutine s_base_onelev_dump + + subroutine s_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_s_base_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_d" + 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 + + ! At base level do nothing for the smoother + if (allocated(sm%sv)) & + & call sm%sv%dump(ictxt,level,info,solver=solver) + + end subroutine s_base_smoother_dmp + + subroutine s_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + use psb_sparse_mod + implicit none + class(mld_s_base_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 + + ! At base level do nothing for the solver + + end subroutine s_base_solver_dmp + end module mld_s_prec_type diff --git a/mlprec/mld_s_slu_solver.f90 b/mlprec/mld_s_slu_solver.f90 new file mode 100644 index 00000000..d758ad83 --- /dev/null +++ b/mlprec/mld_s_slu_solver.f90 @@ -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 diff --git a/mlprec/mld_saggrmap_bld.f90 b/mlprec/mld_saggrmap_bld.f90 index 72afe3df..74a72ff2 100644 --- a/mlprec/mld_saggrmap_bld.f90 +++ b/mlprec/mld_saggrmap_bld.f90 @@ -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 diff --git a/mlprec/mld_saggrmat_asb.f90 b/mlprec/mld_saggrmat_asb.f90 index e315de7d..8802e484 100644 --- a/mlprec/mld_saggrmat_asb.f90 +++ b/mlprec/mld_saggrmat_asb.f90 @@ -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) diff --git a/mlprec/mld_saggrmat_nosmth_asb.F90 b/mlprec/mld_saggrmat_nosmth_asb.F90 index bbf90ab3..bd839ab3 100644 --- a/mlprec/mld_saggrmat_nosmth_asb.F90 +++ b/mlprec/mld_saggrmat_nosmth_asb.F90 @@ -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) diff --git a/mlprec/mld_saggrmat_smth_asb.F90 b/mlprec/mld_saggrmat_smth_asb.F90 index ec723445..d19b4e2d 100644 --- a/mlprec/mld_saggrmat_smth_asb.F90 +++ b/mlprec/mld_saggrmat_smth_asb.F90 @@ -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_) diff --git a/mlprec/mld_scoarse_bld.f90 b/mlprec/mld_scoarse_bld.f90 index f0563a1b..9abd7e96 100644 --- a/mlprec/mld_scoarse_bld.f90 +++ b/mlprec/mld_scoarse_bld.f90 @@ -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 diff --git a/mlprec/mld_silu0_fact.f90 b/mlprec/mld_silu0_fact.f90 index 2094a7c1..08b0c5de 100644 --- a/mlprec/mld_silu0_fact.f90 +++ b/mlprec/mld_silu0_fact.f90 @@ -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 diff --git a/mlprec/mld_siluk_fact.f90 b/mlprec/mld_siluk_fact.f90 index 9b4ca5ac..1de372c6 100644 --- a/mlprec/mld_siluk_fact.f90 +++ b/mlprec/mld_siluk_fact.f90 @@ -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 diff --git a/mlprec/mld_silut_fact.f90 b/mlprec/mld_silut_fact.f90 index ec8bada7..07a511ec 100644 --- a/mlprec/mld_silut_fact.f90 +++ b/mlprec/mld_silut_fact.f90 @@ -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 diff --git a/mlprec/mld_smlprec_aply.f90 b/mlprec/mld_smlprec_aply.f90 index c335352b..26148221 100644 --- a/mlprec/mld_smlprec_aply.f90 +++ b/mlprec/mld_smlprec_aply.f90 @@ -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 diff --git a/mlprec/mld_smlprec_bld.f90 b/mlprec/mld_smlprec_bld.f90 index 557d8778..3a463a45 100644 --- a/mlprec/mld_smlprec_bld.f90 +++ b/mlprec/mld_smlprec_bld.f90 @@ -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 diff --git a/mlprec/mld_sprecaply.f90 b/mlprec/mld_sprecaply.f90 index 1c32f864..935bffc7 100644 --- a/mlprec/mld_sprecaply.f90 +++ b/mlprec/mld_sprecaply.f90 @@ -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 diff --git a/mlprec/mld_sprecbld.f90 b/mlprec/mld_sprecbld.f90 index b976a300..3c62a3a1 100644 --- a/mlprec/mld_sprecbld.f90 +++ b/mlprec/mld_sprecbld.f90 @@ -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 diff --git a/mlprec/mld_sprecinit.F90 b/mlprec/mld_sprecinit.F90 index 5a2e4f0b..7a0cead3 100644 --- a/mlprec/mld_sprecinit.F90 +++ b/mlprec/mld_sprecinit.F90 @@ -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,'"' diff --git a/mlprec/mld_sprecset.F90 b/mlprec/mld_sprecset.F90 index 1f2ebaa2..abeb0c03 100644 --- a/mlprec/mld_sprecset.F90 +++ b/mlprec/mld_sprecset.F90 @@ -79,16 +79,19 @@ subroutine mld_sprecseti(p,what,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_sprecseti + use mld_s_prec_mod, mld_protect_name => mld_sprecseti use mld_s_jac_smoother use mld_s_as_smoother use mld_s_diag_solver use mld_s_ilu_solver - + use mld_s_id_solver +#ifdef HAVE_SLU_ + use mld_s_slu_solver +#endif implicit none -! Arguments + ! Arguments type(mld_sprec_type), intent(inout) :: p integer, intent(in) :: what integer, intent(in) :: val @@ -103,7 +106,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev) if (.not.allocated(p%precv)) then info = 3111 - write(0,*) name,': Error: uninitialized preconditioner,',& + write(psb_err_unit,*) name,': Error: uninitialized preconditioner,',& &' should call MLD_PRECINIT' return endif @@ -117,7 +120,7 @@ subroutine mld_sprecseti(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 @@ -132,56 +135,43 @@ subroutine mld_sprecseti(p,what,val,info,ilev) ! select case(what) case(mld_smoother_type_) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_smoother_sweeps_) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + 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_) - p%precv(ilev_)%iprcparm(what) = val + & 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_) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_smoother_sweeps_) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - p%precv(ilev_)%prec%iprcparm(what) = val - case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& + 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_) - 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_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& + & mld_sub_restr_,mld_sub_prol_, & + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & 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' @@ -190,16 +180,30 @@ subroutine mld_sprecseti(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 @@ -207,17 +211,15 @@ subroutine mld_sprecseti(p,what,val,info,ilev) info = -2 return end if - p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = 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 @@ -231,118 +233,92 @@ subroutine mld_sprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) + 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_)%iprcparm(what) = val - 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) - p%precv(ilev_)%iprcparm(what) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val - p%precv(ilev_)%prec%iprcparm(what) = val + call p%precv(ilev_)%set(what,val,info) end do case(mld_smoother_type_) - do ilev_=1,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 - p%precv(ilev_)%prec%iprcparm(what) = val + 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_sweeps_pre_,mld_smoother_sweeps_post_,& & mld_smoother_pos_,mld_aggr_omega_alg_,& & mld_aggr_eig_,mld_aggr_filter_) do ilev_=1,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 + 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 - case(mld_jac_) - p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_ - p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ - 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) then - p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val - p%precv(nlev_)%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(nlev_)%iprcparm(mld_smoother_sweeps_post_) = val - p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_pre_) = val - p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_post_) = val + 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 @@ -350,33 +326,205 @@ subroutine mld_sprecseti(p,what,val,info,ilev) endif - do ilev_=1, nlev_ - write(0,*) 'Check on mld_sprecseti level ',ilev_,' ',allocated(p%precv(ilev_)%sm) - end do +contains + + subroutine onelev_set_smoother(level,val,info) + type(mld_sonelev_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_s_base_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_s_base_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_s_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_base_smoother_type ::& + & level%sm, stat=info) + if (info ==0) allocate(mld_s_id_solver_type ::& + & level%sm%sv, stat=info) + call level%sm%default() + endif + + case (mld_jac_) + if (allocated(level%sm)) then + select type (sm => level%sm) + class is (mld_s_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_s_jac_smoother_type :: & + & level%sm, stat=info) + if (info == 0) allocate(mld_s_diag_solver_type :: & + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_s_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_s_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_s_jac_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_s_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_s_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_s_as_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_s_as_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_s_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_as_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_s_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_sonelev_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_s_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_s_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_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_s_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_s_diag_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_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_s_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_s_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_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_s_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_s_slu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_s_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_sprecseti -subroutine mld_sprecsetsm(p,what,val,info,ilev) +subroutine mld_sprecsetsm(p,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_sprecsetsm - use mld_s_jac_smoother - use mld_s_as_smoother - use mld_s_diag_solver - use mld_s_ilu_solver - + use mld_s_prec_mod, mld_protect_name => mld_sprecsetsm implicit none ! Arguments 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 ! Local variables - integer :: ilev_, nlev_ + integer :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -391,8 +539,12 @@ subroutine mld_sprecsetsm(p,what,val,info,ilev) 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 @@ -400,271 +552,40 @@ subroutine mld_sprecsetsm(p,what,val,info,ilev) write(0,*) 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. -!!$ ! -!!$ if (present(ilev)) then -!!$ -!!$ if (ilev_ == 1) then -!!$ ! -!!$ ! Rules for fine level are slightly different. -!!$ ! -!!$ select case(what) -!!$ case(mld_smoother_type_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_smoother_sweeps_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ 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_,& -!!$ & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ else if (ilev_ > 1) then -!!$ select case(what) -!!$ case(mld_smoother_type_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_smoother_sweeps_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ 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_,& -!!$ & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_) -!!$ 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 -!!$ 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 -!!$ case(mld_coarse_solve_) -!!$ if (ilev_ /= nlev_) then -!!$ write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' -!!$ info = -2 -!!$ return -!!$ 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_ -!!$ 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_sweeps_) -!!$ 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_smoother_sweeps_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ 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 -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ endif -!!$ -!!$ else if (.not.present(ilev)) then -!!$ ! -!!$ ! ilev not specified: set preconditioner parameters at all the appropriate -!!$ ! levels -!!$ ! -!!$ select case(what) -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ do ilev_=1,max(1,nlev_-1) -!!$ 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 -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ case(mld_smoother_sweeps_) -!!$ do ilev_=1,max(1,nlev_-1) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ -!!$ case(mld_smoother_type_) -!!$ do ilev_=1,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 -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& -!!$ & 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_ -!!$ 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 -!!$ 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 -!!$ 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 -!!$ 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 -!!$ case(mld_jac_) -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ 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 -!!$ -!!$ 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) then -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val -!!$ p%precv(nlev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(nlev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_post_) = val -!!$ 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 -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ 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_sprecsetsm -subroutine mld_sprecsetsv(p,what,val,info,ilev) +subroutine mld_sprecsetsv(p,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_sprecsetsv - use mld_s_diag_solver - use mld_s_ilu_solver - + use mld_s_prec_mod, mld_protect_name => mld_sprecsetsv implicit none ! Arguments 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 ! Local variables - integer :: ilev_, nlev_ + integer :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -679,258 +600,44 @@ subroutine mld_sprecsetsv(p,what,val,info,ilev) 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 - 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. - ! -!!$ if (present(ilev)) then -!!$ -!!$ if (ilev_ == 1) then -!!$ ! -!!$ ! Rules for fine level are slightly different. -!!$ ! -!!$ select case(what) -!!$ case(mld_smoother_type_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_smoother_sweeps_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ 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_,& -!!$ & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ else if (ilev_ > 1) then -!!$ select case(what) -!!$ case(mld_smoother_type_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_smoother_sweeps_) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ 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_,& -!!$ & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_) -!!$ 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 -!!$ 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 -!!$ case(mld_coarse_solve_) -!!$ if (ilev_ /= nlev_) then -!!$ write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV' -!!$ info = -2 -!!$ return -!!$ 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_ -!!$ 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_sweeps_) -!!$ 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_smoother_sweeps_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ 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 -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ endif -!!$ -!!$ else if (.not.present(ilev)) then -!!$ ! -!!$ ! ilev not specified: set preconditioner parameters at all the appropriate -!!$ ! levels -!!$ ! -!!$ select case(what) -!!$ case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& -!!$ & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) -!!$ do ilev_=1,max(1,nlev_-1) -!!$ 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 -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ case(mld_smoother_sweeps_) -!!$ do ilev_=1,max(1,nlev_-1) -!!$ p%precv(ilev_)%iprcparm(what) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(ilev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ -!!$ case(mld_smoother_type_) -!!$ do ilev_=1,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 -!!$ p%precv(ilev_)%prec%iprcparm(what) = val -!!$ end do -!!$ case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,& -!!$ & 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_ -!!$ 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 -!!$ 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 -!!$ 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 -!!$ 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 -!!$ case(mld_jac_) -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ 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 -!!$ -!!$ 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) then -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val -!!$ p%precv(nlev_)%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(nlev_)%iprcparm(mld_smoother_sweeps_post_) = val -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_pre_) = val -!!$ p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_post_) = val -!!$ 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 -!!$ case default -!!$ write(0,*) name,': Error: invalid WHAT' -!!$ info = -2 -!!$ end select -!!$ -!!$ 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_sprecsetsv @@ -977,7 +684,7 @@ end subroutine mld_sprecsetsv subroutine mld_sprecsetc(p,what,string,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_sprecsetc + use mld_s_prec_mod, mld_protect_name => mld_sprecsetc implicit none @@ -1011,13 +718,6 @@ subroutine mld_sprecsetc(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) @@ -1068,7 +768,7 @@ end subroutine mld_sprecsetc subroutine mld_sprecsetr(p,what,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_sprecsetr + use mld_s_prec_mod, mld_protect_name => mld_sprecsetr implicit none @@ -1105,12 +805,6 @@ subroutine mld_sprecsetr(p,what,val,info,ilev) 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. @@ -1123,7 +817,8 @@ subroutine mld_sprecsetr(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 @@ -1132,9 +827,9 @@ subroutine mld_sprecsetr(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 @@ -1149,42 +844,20 @@ subroutine mld_sprecsetr(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' diff --git a/mlprec/mld_sslu_bld.f90 b/mlprec/mld_sslu_bld.f90 index dbdec4cf..ed73abd5 100644 --- a/mlprec/mld_sslu_bld.f90 +++ b/mlprec/mld_sslu_bld.f90 @@ -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 diff --git a/mlprec/mld_sslu_interface.c b/mlprec/mld_sslu_interface.c index 90b18389..c9fa64af 100644 --- a/mlprec/mld_sslu_interface.c +++ b/mlprec/mld_sslu_interface.c @@ -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 } diff --git a/mlprec/mld_sslud_bld.f90 b/mlprec/mld_sslud_bld.f90 index 52c5833b..26f2679e 100644 --- a/mlprec/mld_sslud_bld.f90 +++ b/mlprec/mld_sslud_bld.f90 @@ -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 diff --git a/mlprec/mld_ssp_renum.f90 b/mlprec/mld_ssp_renum.f90 index 88ef7955..2e2cb8e1 100644 --- a/mlprec/mld_ssp_renum.f90 +++ b/mlprec/mld_ssp_renum.f90 @@ -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 diff --git a/mlprec/mld_sumf_bld.f90 b/mlprec/mld_sumf_bld.f90 index 8c83e339..82c8ee76 100644 --- a/mlprec/mld_sumf_bld.f90 +++ b/mlprec/mld_sumf_bld.f90 @@ -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 diff --git a/mlprec/mld_z_as_smoother.f90 b/mlprec/mld_z_as_smoother.f90 index e79a18ee..6cd35bef 100644 --- a/mlprec/mld_z_as_smoother.f90 +++ b/mlprec/mld_z_as_smoother.f90 @@ -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 diff --git a/mlprec/mld_z_id_solver.f90 b/mlprec/mld_z_id_solver.f90 new file mode 100644 index 00000000..ad72ff8e --- /dev/null +++ b/mlprec/mld_z_id_solver.f90 @@ -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 diff --git a/mlprec/mld_z_ilu_solver.f90 b/mlprec/mld_z_ilu_solver.f90 index 23381a9a..9d7cab46 100644 --- a/mlprec/mld_z_ilu_solver.f90 +++ b/mlprec/mld_z_ilu_solver.f90 @@ -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 diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 new file mode 100644 index 00000000..ac771c9c --- /dev/null +++ b/mlprec/mld_z_inner_mod.f90 @@ -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 diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index a256011d..22d4798c 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -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_ diff --git a/mlprec/mld_z_move_alloc_mod.f90 b/mlprec/mld_z_move_alloc_mod.f90 new file mode 100644 index 00000000..42043fc6 --- /dev/null +++ b/mlprec/mld_z_move_alloc_mod.f90 @@ -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 diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 new file mode 100644 index 00000000..3ec1ec75 --- /dev/null +++ b/mlprec/mld_z_prec_mod.f90 @@ -0,0 +1,161 @@ +!!$ +!!$ +!!$ 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_z_prec_mod + + use mld_z_prec_type + use mld_z_move_alloc_mod + + interface mld_precinit + subroutine mld_zprecinit(p,ptype,info,nlev) + use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ + use mld_z_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_zprecseti, mld_i_zprecsetc, mld_i_zprecsetr + end interface + + interface mld_inner_precset + subroutine mld_zprecsetsm(p,what,val,info,ilev) + use mld_z_prec_type, only : mld_zprec_type, mld_z_base_smoother_type + type(mld_zprec_type), intent(inout) :: p + integer, intent(in) :: what + class(mld_z_base_smoother_type), intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + end subroutine mld_zprecsetsm + subroutine mld_zprecsetsv(p,what,val,info,ilev) + use mld_z_prec_type, only : mld_zprec_type, mld_z_base_solver_type + type(mld_zprec_type), intent(inout) :: p + integer, intent(in) :: what + class(mld_z_base_solver_type), intent(in) :: val + integer, intent(out) :: info + integer, optional, intent(in) :: ilev + end subroutine mld_zprecsetsv + subroutine mld_zprecseti(p,what,val,info,ilev) + use mld_z_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_z_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_z_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_precbld + subroutine mld_zprecbld(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_zprecbld + end interface + +contains + + + subroutine mld_i_zprecseti(p,what,val,info) + use psb_sparse_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ + use mld_z_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_z_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_z_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 + + +end module mld_z_prec_mod diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index 32e9cb3a..0212c682 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -133,7 +133,7 @@ module mld_z_prec_type ! integer, allocatable :: iprcparm(:) ! real(psb_Tpk_), allocatable :: rprcparm(:) ! integer, allocatable :: perm(:), invperm(:) - ! end type mld_sbaseprec_type + ! end type mld_zbaseprec_type ! ! Note that IntrType denotes the real or complex data type, and psb_Tpk denotes ! the kind of the real or complex type, according to the real/complex, single/double @@ -177,6 +177,8 @@ module mld_z_prec_type type mld_z_base_solver_type contains + procedure, pass(sv) :: check => z_base_solver_check + procedure, pass(sv) :: dump => z_base_solver_dmp procedure, pass(sv) :: build => z_base_solver_bld procedure, pass(sv) :: apply => z_base_solver_apply procedure, pass(sv) :: free => z_base_solver_free @@ -192,6 +194,8 @@ module mld_z_prec_type type mld_z_base_smoother_type class(mld_z_base_solver_type), allocatable :: sv contains + procedure, pass(sm) :: check => z_base_smoother_check + procedure, pass(sm) :: dump => z_base_smoother_dmp procedure, pass(sm) :: build => z_base_smoother_bld procedure, pass(sm) :: apply => z_base_smoother_apply procedure, pass(sm) :: free => z_base_smoother_free @@ -200,27 +204,23 @@ module mld_z_prec_type procedure, pass(sm) :: setr => z_base_smoother_setr generic, public :: set => seti, setc, setr procedure, pass(sm) :: default => z_base_smoother_default - procedure, pass(sm) :: descr => z_base_smoother_descr - procedure, pass(sm) :: sizeof => z_base_smoother_sizeof + procedure, pass(sm) :: descr => z_base_smoother_descr + procedure, pass(sm) :: sizeof => z_base_smoother_sizeof end type mld_z_base_smoother_type - type, extends(psb_z_base_prec_type) :: mld_zbaseprec_type - integer, allocatable :: iprcparm(:) - real(psb_dpk_), allocatable :: rprcparm(:) - end type mld_zbaseprec_type - type mld_zonelev_type class(mld_z_base_smoother_type), allocatable :: sm - integer :: sweeps, sweeps_pre, sweeps_post - type(mld_zbaseprec_type) :: prec - integer, allocatable :: iprcparm(:) - real(psb_dpk_), allocatable :: rprcparm(:) - type(psb_zspmat_type) :: ac + type(mld_dml_parms) :: parms + type(psb_zspmat_type) :: ac type(psb_desc_type) :: desc_ac - type(psb_zspmat_type), pointer :: base_a => null() + type(psb_zspmat_type), pointer :: base_a => null() type(psb_desc_type), pointer :: base_desc => null() type(psb_zlinmap_type) :: map contains + procedure, pass(lv) :: descr => z_base_onelev_descr + procedure, pass(lv) :: default => z_base_onelev_default + procedure, pass(lv) :: check => z_base_onelev_check + procedure, pass(lv) :: dump => z_base_onelev_dump procedure, pass(lv) :: seti => z_base_onelev_seti procedure, pass(lv) :: setr => z_base_onelev_setr procedure, pass(lv) :: setc => z_base_onelev_setc @@ -233,18 +233,25 @@ module mld_z_prec_type contains procedure, pass(prec) :: z_apply2v => mld_z_apply2v procedure, pass(prec) :: z_apply1v => mld_z_apply1v + procedure, pass(prec) :: dump => mld_z_dump end type mld_zprec_type private :: z_base_solver_bld, z_base_solver_apply, & & z_base_solver_free, z_base_solver_seti, & & z_base_solver_setc, z_base_solver_setr, & & z_base_solver_descr, z_base_solver_sizeof, & - & z_base_solver_default, & + & z_base_solver_default, z_base_solver_check,& + & z_base_solver_dmp, & & z_base_smoother_bld, z_base_smoother_apply, & & z_base_smoother_free, z_base_smoother_seti, & & z_base_smoother_setc, z_base_smoother_setr,& & z_base_smoother_descr, z_base_smoother_sizeof, & - & z_base_smoother_default + & z_base_smoother_default, z_base_smoother_check, & + & z_base_smoother_dmp, & + & z_base_onelev_seti, z_base_onelev_setc, & + & z_base_onelev_setr, z_base_onelev_check, & + & z_base_onelev_default, z_base_onelev_dump, & + & z_base_onelev_descr ! @@ -253,11 +260,7 @@ module mld_z_prec_type ! interface mld_precfree - module procedure mld_zbase_precfree, mld_z_onelev_precfree, mld_zprec_free - end interface - - interface mld_nullify_baseprec - module procedure mld_nullify_zbaseprec + module procedure mld_z_onelev_precfree, mld_zprec_free end interface interface mld_nullify_onelevprec @@ -269,7 +272,7 @@ module mld_z_prec_type end interface interface mld_sizeof - module procedure mld_zprec_sizeof, mld_zbaseprec_sizeof, mld_z_onelev_prec_sizeof + module procedure mld_zprec_sizeof, mld_z_onelev_prec_sizeof end interface interface mld_precaply @@ -314,55 +317,13 @@ contains end if end function mld_zprec_sizeof - function mld_zbaseprec_sizeof(prec) result(val) - implicit none - type(mld_zbaseprec_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_sp * size(prec%d) -!!$ if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) -!!$ if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) -!!$ val = val + psb_sizeof(prec%desc_data) -!!$ if (allocated(prec%av)) then -!!$ do i=1,size(prec%av) -!!$ val = val + psb_sizeof(prec%av(i)) -!!$ end do -!!$ end if - - - end function mld_zbaseprec_sizeof - function mld_z_onelev_prec_sizeof(prec) result(val) implicit none type(mld_zonelev_type), intent(in) :: prec 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) @@ -422,10 +383,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 @@ -445,16 +414,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 ! @@ -464,8 +423,7 @@ contains ! ilev=2 - call mld_ml_alg_descr(iout_,ilev,p%precv(ilev)%iprcparm, info,& - & dprcparm=p%precv(ilev)%rprcparm) + call p%precv(ilev)%parms%descr(iout_,info) ! ! Coarse matrices are different at levels 2,...,nlev-1, hence related @@ -473,24 +431,21 @@ contains ! 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 ! + ! 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 @@ -517,56 +472,66 @@ contains ! info - integer, output. ! error code. ! - subroutine mld_zbase_precfree(p,info) - implicit none - type(mld_zbaseprec_type), intent(inout) :: p + + subroutine z_base_onelev_descr(lv,info,iout,coarse) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_zonelev_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_z_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_zslu_free(p%iprcparm(mld_slu_ptr_),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) - end subroutine mld_zbase_precfree + if (allocated(lv%sm)) & + & call lv%sm%descr(info,iout=iout_) + + 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_base_onelev_descr subroutine mld_z_onelev_precfree(p,info) use psb_sparse_mod @@ -579,16 +544,14 @@ contains info = psb_success_ ! Actually we might just deallocate the top level array, except - ! for the inner UMFPACK or SLU stuff - call mld_precfree(p%prec,info) + ! for the inner UMFPACK or SLU stuff. + ! We really need FINALs. + call p%sm%free(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. @@ -603,14 +566,6 @@ contains call mld_nullify_onelevprec(p) end subroutine mld_z_onelev_precfree - subroutine mld_nullify_zbaseprec(p) - implicit none - - type(mld_zbaseprec_type), intent(inout) :: p - - - end subroutine mld_nullify_zbaseprec - subroutine mld_nullify_z_onelevprec(p) implicit none @@ -675,7 +630,7 @@ contains integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_apply' + character(len=20) :: name='z_base_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ @@ -702,6 +657,44 @@ contains end subroutine z_base_smoother_apply + subroutine z_base_smoother_check(sm,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_z_base_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='z_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 z_base_smoother_check + + subroutine z_base_smoother_seti(sm,what,val,info) use psb_sparse_mod @@ -714,7 +707,7 @@ contains integer, intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_seti' + character(len=20) :: name='z_base_smoother_seti' call psb_erractionsave(err_act) info = psb_success_ @@ -747,7 +740,7 @@ contains character(len=*), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_setc' + character(len=20) :: name='z_base_smoother_setc' call psb_erractionsave(err_act) @@ -782,7 +775,7 @@ contains real(psb_dpk_), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_setr' + character(len=20) :: name='z_base_smoother_setr' call psb_erractionsave(err_act) @@ -819,7 +812,7 @@ contains character, intent(in) :: upd integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_bld' + character(len=20) :: name='z_base_smoother_bld' call psb_erractionsave(err_act) @@ -855,7 +848,7 @@ contains class(mld_z_base_smoother_type), intent(inout) :: sm integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_smoother_free' + character(len=20) :: name='z_base_smoother_free' call psb_erractionsave(err_act) info = psb_success_ @@ -967,11 +960,11 @@ contains integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_apply' + character(len=20) :: name='z_base_solver_apply' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1002,11 +995,11 @@ contains integer, intent(out) :: info type(psb_zspmat_type), intent(in), target, optional :: b Integer :: err_act - character(len=20) :: name='d_base_solver_bld' + character(len=20) :: name='z_base_solver_bld' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1023,6 +1016,36 @@ contains end subroutine z_base_solver_bld + subroutine z_base_solver_check(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_z_base_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='z_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 z_base_solver_check + subroutine z_base_solver_seti(sv,what,val,info) use psb_sparse_mod @@ -1035,23 +1058,11 @@ contains integer, intent(in) :: val 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 + character(len=20) :: name='z_base_solver_seti' + + ! Correct action here is doing nothing. + info = 0 + return end subroutine z_base_solver_seti @@ -1066,14 +1077,18 @@ contains integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_base_solver_setc' + Integer :: err_act, ival + character(len=20) :: name='z_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 @@ -1099,23 +1114,12 @@ contains real(psb_dpk_), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_setr' + character(len=20) :: name='z_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 z_base_solver_setr @@ -1129,11 +1133,11 @@ contains class(mld_z_base_solver_type), intent(inout) :: sv integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_solver_free' + character(len=20) :: name='z_base_solver_free' call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1169,7 +1173,7 @@ contains call psb_erractionsave(err_act) - info = 700 + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 @@ -1224,7 +1228,7 @@ contains type is (mld_zprec_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 @@ -1258,7 +1262,7 @@ contains type is (mld_zprec_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 @@ -1276,6 +1280,81 @@ contains end subroutine mld_z_apply1v + subroutine z_base_onelev_check(lv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_zonelev_type), intent(inout) :: lv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='z_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 z_base_onelev_check + + + subroutine z_base_onelev_default(lv) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_zonelev_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 = szero + lv%parms%aggr_thresh = szero + + if (allocated(lv%sm)) call lv%sm%default() + + return + + end subroutine z_base_onelev_default + subroutine z_base_onelev_seti(lv,what,val,info) use psb_sparse_mod @@ -1288,20 +1367,51 @@ contains integer, intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_onelev_seti' + character(len=20) :: name='z_base_onelev_seti' call psb_erractionsave(err_act) 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) @@ -1332,15 +1442,16 @@ contains character(len=*), intent(in) :: val integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='d_base_onelev_setc' + character(len=20) :: name='z_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) @@ -1373,11 +1484,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 @@ -1391,5 +1512,169 @@ contains return end subroutine z_base_onelev_setr + subroutine mld_z_dump(prec,info,istart,iend,prefix,head,ac,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_zprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, intent(in), optional :: istart, iend + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver,ac + 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 + + iln = size(prec%precv) + if (present(istart)) then + il1 = max(1,istart) + else + il1 = 2 + end if + if (present(iend)) then + iln = min(iln, iend) + end if + + do lev=il1, iln + call prec%precv(lev)%dump(lev,info,prefix=prefix,head=head,& + & ac=ac,smoother=smoother,solver=solver) + end do + + end subroutine mld_z_dump + + subroutine z_base_onelev_dump(lv,level,info,prefix,head,ac,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_zonelev_type), intent(in) :: lv + integer, intent(in) :: level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: ac, 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 :: ac_ + ! len of prefix_ + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_lev_z" + end if + + if (associated(lv%base_desc)) then + icontxt = psb_cd_get_context(lv%base_desc) + call psb_info(icontxt,iam,np) + else + icontxt = -1 + iam = -1 + end if + if (present(ac)) then + ac_ = ac + else + ac_ = .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 (level >= 2) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + write(0,*) 'Filename ',fname + if (ac_) call lv%ac%print(fname,head=head) + end if + if (allocated(lv%sm)) & + & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver) + + end subroutine z_base_onelev_dump + + subroutine z_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + use psb_sparse_mod + implicit none + class(mld_z_base_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_d" + 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 + + ! At base level do nothing for the smoother + if (allocated(sm%sv)) & + & call sm%sv%dump(ictxt,level,info,solver=solver) + + end subroutine z_base_smoother_dmp + + subroutine z_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + use psb_sparse_mod + implicit none + class(mld_z_base_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 + + ! At base level do nothing for the solver + + end subroutine z_base_solver_dmp + + end module mld_z_prec_type diff --git a/mlprec/mld_z_slu_solver.f90 b/mlprec/mld_z_slu_solver.f90 new file mode 100644 index 00000000..9e128e38 --- /dev/null +++ b/mlprec/mld_z_slu_solver.f90 @@ -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_z_slu_solver + + use iso_c_binding + use mld_z_prec_type + + type, extends(mld_z_base_solver_type) :: mld_z_slu_solver_type + type(c_ptr) :: lufactors=c_null_ptr + integer(c_long_long) :: symbsize=0, numsize=0 + contains + procedure, pass(sv) :: build => z_slu_solver_bld + procedure, pass(sv) :: apply => z_slu_solver_apply + procedure, pass(sv) :: free => z_slu_solver_free + procedure, pass(sv) :: seti => z_slu_solver_seti + procedure, pass(sv) :: setc => z_slu_solver_setc + procedure, pass(sv) :: setr => z_slu_solver_setr + procedure, pass(sv) :: descr => z_slu_solver_descr + procedure, pass(sv) :: sizeof => z_slu_solver_sizeof + end type mld_z_slu_solver_type + + + private :: z_slu_solver_bld, z_slu_solver_apply, & + & z_slu_solver_free, z_slu_solver_seti, & + & z_slu_solver_setc, z_slu_solver_setr,& + & z_slu_solver_descr, z_slu_solver_sizeof + + + interface + function mld_zslu_fact(n,nnz,values,rowptr,colind,& + & lufactors)& + & bind(c,name='mld_zslu_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_double) :: values(*) + type(c_ptr) :: lufactors + end function mld_zslu_fact + end interface + + interface + function mld_zslu_solve(itrans,n,x, b, ldb, lufactors)& + & bind(c,name='mld_zslu_solve') result(info) + use iso_c_binding + integer(c_int) :: info + integer(c_int), value :: itrans,n,ldb + complex(c_double) :: x(*), b(ldb,*) + type(c_ptr), value :: lufactors + end function mld_zslu_solve + end interface + + interface + function mld_zslu_free(lufactors)& + & bind(c,name='mld_zslu_free') result(info) + use iso_c_binding + integer(c_int) :: info + type(c_ptr), value :: lufactors + end function mld_zslu_free + end interface + +contains + + subroutine z_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_z_slu_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(:) + integer :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='z_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_dpk_)') + goto 9999 + end if + endif + + select case(trans_) + case('N') + info = mld_zslu_solve(0,n_row,ww,x,n_row,sv%lufactors) + case('T') + info = mld_zslu_solve(1,n_row,ww,x,n_row,sv%lufactors) + case('C') + info = mld_zslu_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 z_slu_solver_apply + + subroutine z_slu_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_slu_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer, intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + ! Local variables + type(psb_zspmat_type) :: atmp + type(psb_z_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='z_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_zslu_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_zslu_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 z_slu_solver_bld + + + subroutine z_slu_solver_seti(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_z_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='z_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 z_slu_solver_seti + + subroutine z_slu_solver_setc(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_z_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='z_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 z_slu_solver_setc + + subroutine z_slu_solver_setr(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_z_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='z_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 z_slu_solver_setr + + subroutine z_slu_solver_free(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_z_slu_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='z_slu_solver_free' + + call psb_erractionsave(err_act) + + + info = mld_zslu_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 z_slu_solver_free + + subroutine z_slu_solver_descr(sv,info,iout) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_z_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_z_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 z_slu_solver_descr + + function z_slu_solver_sizeof(sv) result(val) + use psb_sparse_mod + implicit none + ! Arguments + class(mld_z_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 z_slu_solver_sizeof + +end module mld_z_slu_solver diff --git a/mlprec/mld_z_umf_solver.f90 b/mlprec/mld_z_umf_solver.f90 index 8011e788..c4ba378f 100644 --- a/mlprec/mld_z_umf_solver.f90 +++ b/mlprec/mld_z_umf_solver.f90 @@ -153,8 +153,10 @@ contains select case(trans_) case('N') info = mld_zumf_solve(0,n_row,ww,x,n_row,sv%numeric) - case('T','C') + case('T') info = mld_zumf_solve(1,n_row,ww,x,n_row,sv%numeric) + case('C') + info = mld_zumf_solve(2,n_row,ww,x,n_row,sv%numeric) case default call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve') goto 9999 diff --git a/mlprec/mld_zaggrmap_bld.f90 b/mlprec/mld_zaggrmap_bld.f90 index 7974b0d6..19fcc6e3 100644 --- a/mlprec/mld_zaggrmap_bld.f90 +++ b/mlprec/mld_zaggrmap_bld.f90 @@ -82,7 +82,7 @@ subroutine mld_zaggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zaggrmap_bld + use mld_z_inner_mod, mld_protect_name => mld_zaggrmap_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_z_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 diff --git a/mlprec/mld_zaggrmat_asb.f90 b/mlprec/mld_zaggrmat_asb.f90 index 18e2f2fa..f273b40a 100644 --- a/mlprec/mld_zaggrmat_asb.f90 +++ b/mlprec/mld_zaggrmat_asb.f90 @@ -101,7 +101,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zaggrmat_asb + use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_asb implicit none @@ -126,7 +126,7 @@ subroutine mld_zaggrmat_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) diff --git a/mlprec/mld_zaggrmat_nosmth_asb.F90 b/mlprec/mld_zaggrmat_nosmth_asb.F90 index e9908813..b26f9723 100644 --- a/mlprec/mld_zaggrmat_nosmth_asb.F90 +++ b/mlprec/mld_zaggrmat_nosmth_asb.F90 @@ -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_zprecinit and mld_zprecset. ! ! For details see @@ -83,7 +83,7 @@ ! subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zaggrmat_nosmth_asb + use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_nosmth_asb #ifdef MPI_MOD use mpi @@ -136,7 +136,7 @@ subroutine mld_zaggrmat_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_zaggrmat_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_zaggrmat_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_zaggrmat_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) diff --git a/mlprec/mld_zaggrmat_smth_asb.F90 b/mlprec/mld_zaggrmat_smth_asb.F90 index 2600dc45..848711d9 100644 --- a/mlprec/mld_zaggrmat_smth_asb.F90 +++ b/mlprec/mld_zaggrmat_smth_asb.F90 @@ -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_zprecinit and mld_zprecset. ! ! 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_zprecinit and mld_zprecset. ! ! For more details see @@ -100,7 +100,7 @@ ! subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zaggrmat_smth_asb + use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_smth_asb #ifdef MPI_MOD use mpi @@ -150,7 +150,7 @@ subroutine mld_zaggrmat_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_zaggrmat_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_zaggrmat_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_zaggrmat_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_zaggrmat_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_zaggrmat_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_zaggrmat_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,15 +501,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' coarse matrix construction' - - 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_) @@ -583,7 +579,6 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) @@ -604,7 +599,7 @@ subroutine mld_zaggrmat_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_) diff --git a/mlprec/mld_zas_aply.f90 b/mlprec/mld_zas_aply.f90 index 56edb8af..b578b44c 100644 --- a/mlprec/mld_zas_aply.f90 +++ b/mlprec/mld_zas_aply.f90 @@ -77,7 +77,7 @@ subroutine mld_zas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zas_aply + use mld_z_inner_mod, mld_protect_name => mld_zas_aply implicit none diff --git a/mlprec/mld_zas_bld.f90 b/mlprec/mld_zas_bld.f90 index 89c49090..d26c2575 100644 --- a/mlprec/mld_zas_bld.f90 +++ b/mlprec/mld_zas_bld.f90 @@ -69,7 +69,7 @@ subroutine mld_zas_bld(a,desc_a,p,upd,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zas_bld + use mld_z_inner_mod, mld_protect_name => mld_zas_bld Implicit None diff --git a/mlprec/mld_zbaseprec_aply.f90 b/mlprec/mld_zbaseprec_aply.f90 index 7cc3acd8..42030411 100644 --- a/mlprec/mld_zbaseprec_aply.f90 +++ b/mlprec/mld_zbaseprec_aply.f90 @@ -81,7 +81,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zbaseprec_aply + use mld_z_inner_mod, mld_protect_name => mld_zbaseprec_aply implicit none diff --git a/mlprec/mld_zbaseprec_bld.f90 b/mlprec/mld_zbaseprec_bld.f90 index b1ece81f..6c0e3495 100644 --- a/mlprec/mld_zbaseprec_bld.f90 +++ b/mlprec/mld_zbaseprec_bld.f90 @@ -71,7 +71,7 @@ subroutine mld_zbaseprec_bld(a,desc_a,p,info,upd) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zbaseprec_bld + use mld_z_inner_mod, mld_protect_name => mld_zbaseprec_bld Implicit None diff --git a/mlprec/mld_zcoarse_bld.f90 b/mlprec/mld_zcoarse_bld.f90 index 6033054f..8163bebd 100644 --- a/mlprec/mld_zcoarse_bld.f90 +++ b/mlprec/mld_zcoarse_bld.f90 @@ -68,7 +68,7 @@ subroutine mld_zcoarse_bld(a,desc_a,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zcoarse_bld + use mld_z_inner_mod, mld_protect_name => mld_zcoarse_bld implicit none @@ -90,30 +90,25 @@ subroutine mld_zcoarse_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_zcoarse_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 diff --git a/mlprec/mld_zdiag_bld.f90 b/mlprec/mld_zdiag_bld.f90 index 695b9a27..0daee80f 100644 --- a/mlprec/mld_zdiag_bld.f90 +++ b/mlprec/mld_zdiag_bld.f90 @@ -60,7 +60,7 @@ subroutine mld_zdiag_bld(a,desc_a,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zdiag_bld + use mld_z_inner_mod, mld_protect_name => mld_zdiag_bld Implicit None diff --git a/mlprec/mld_zfact_bld.f90 b/mlprec/mld_zfact_bld.f90 index 63eb312b..128c84a0 100644 --- a/mlprec/mld_zfact_bld.f90 +++ b/mlprec/mld_zfact_bld.f90 @@ -112,7 +112,7 @@ subroutine mld_zfact_bld(a,p,upd,info,blck) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zfact_bld + use mld_z_inner_mod, mld_protect_name => mld_zfact_bld implicit none diff --git a/mlprec/mld_zilu0_fact.f90 b/mlprec/mld_zilu0_fact.f90 index 2c5ea6d5..80ee7838 100644 --- a/mlprec/mld_zilu0_fact.f90 +++ b/mlprec/mld_zilu0_fact.f90 @@ -102,7 +102,7 @@ subroutine mld_zilu0_fact(ialg,a,l,u,d,info,blck,upd) use psb_sparse_mod - use mld_inner_mod!, mld_protect_name => mld_zilu0_fact + use mld_z_inner_mod!, mld_protect_name => mld_zilu0_fact implicit none diff --git a/mlprec/mld_zilu_bld.f90 b/mlprec/mld_zilu_bld.f90 index bbc07ad9..112c6978 100644 --- a/mlprec/mld_zilu_bld.f90 +++ b/mlprec/mld_zilu_bld.f90 @@ -92,7 +92,7 @@ subroutine mld_zilu_bld(a,p,upd,info,blck) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zilu_bld + use mld_z_inner_mod, mld_protect_name => mld_zilu_bld implicit none diff --git a/mlprec/mld_ziluk_fact.f90 b/mlprec/mld_ziluk_fact.f90 index 4bf1af2b..d728c99d 100644 --- a/mlprec/mld_ziluk_fact.f90 +++ b/mlprec/mld_ziluk_fact.f90 @@ -99,7 +99,7 @@ subroutine mld_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) use psb_sparse_mod - use mld_inner_mod!, mld_protect_name => mld_ziluk_fact + use mld_z_inner_mod!, mld_protect_name => mld_ziluk_fact implicit none diff --git a/mlprec/mld_zilut_fact.f90 b/mlprec/mld_zilut_fact.f90 index a01d8879..6d80d469 100644 --- a/mlprec/mld_zilut_fact.f90 +++ b/mlprec/mld_zilut_fact.f90 @@ -95,7 +95,7 @@ subroutine mld_zilut_fact(fill_in,thres,a,l,u,d,info,blck) use psb_sparse_mod - use mld_inner_mod!, mld_protect_name => mld_zilut_fact + use mld_z_inner_mod!, mld_protect_name => mld_zilut_fact implicit none diff --git a/mlprec/mld_zmlprec_aply.f90 b/mlprec/mld_zmlprec_aply.f90 index eb72ae31..bf94bba7 100644 --- a/mlprec/mld_zmlprec_aply.f90 +++ b/mlprec/mld_zmlprec_aply.f90 @@ -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_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zmlprec_aply + use mld_z_inner_mod, mld_protect_name => mld_zmlprec_aply implicit none @@ -357,7 +357,8 @@ subroutine mld_zmlprec_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 @@ -379,7 +380,8 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Inner prec aply') + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') goto 9999 end if @@ -387,7 +389,8 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) & p%precv(level)%base_desc,info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Error final update') + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') goto 9999 end if @@ -453,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 @@ -483,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(zone,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& @@ -511,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_) @@ -552,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(zone,& & mlprec_wrk(level)%x2l,zone,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(zone,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& @@ -590,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(zone,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& @@ -650,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(zone,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& @@ -717,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(zone,& & mlprec_wrk(level)%x2l,zone,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(zone,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& @@ -760,19 +761,20 @@ contains goto 9999 end if end if - call psb_geaxpby(zone,mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%tx,& + call psb_geaxpby(zone,mlprec_wrk(level)%x2l,zzero,& + & 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(zone,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& @@ -814,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(zone,& & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& @@ -833,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 @@ -841,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 diff --git a/mlprec/mld_zmlprec_bld.f90 b/mlprec/mld_zmlprec_bld.f90 index eb9fbed8..29b32f10 100644 --- a/mlprec/mld_zmlprec_bld.f90 +++ b/mlprec/mld_zmlprec_bld.f90 @@ -67,13 +67,8 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zmlprec_bld - use mld_prec_mod - use mld_z_jac_smoother - use mld_z_as_smoother - use mld_z_diag_solver - use mld_z_ilu_solver - use mld_z_umf_solver + use mld_z_inner_mod, mld_protect_name => mld_zmlprec_bld + use mld_z_prec_mod Implicit None @@ -90,6 +85,7 @@ subroutine mld_zmlprec_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 @@ -163,17 +159,10 @@ subroutine mld_zmlprec_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 @@ -188,13 +177,7 @@ subroutine mld_zmlprec_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 @@ -203,12 +186,12 @@ subroutine mld_zmlprec_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 @@ -219,7 +202,6 @@ subroutine mld_zmlprec_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) @@ -285,7 +267,6 @@ subroutine mld_zmlprec_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 @@ -302,77 +283,30 @@ subroutine mld_zmlprec_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',dzero,is_legal_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_z_jac_smoother_type :: p%precv(i)%sm, stat=info) - case(mld_as_) - allocate(mld_z_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_z_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_z_diag_solver_type :: p%precv(i)%sm%sv, stat=info) - case(mld_umf_) - allocate(mld_z_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 @@ -400,86 +334,67 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info) contains - subroutine init_baseprec_av(p,info) - type(mld_zbaseprec_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_zonelev_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_zmlprec_bld diff --git a/mlprec/mld_zprecaply.f90 b/mlprec/mld_zprecaply.f90 index e1c57b07..fe90615d 100644 --- a/mlprec/mld_zprecaply.f90 +++ b/mlprec/mld_zprecaply.f90 @@ -74,7 +74,7 @@ subroutine mld_zprecaply(prec,x,y,desc_data,info,trans,work) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zprecaply + use mld_z_inner_mod, mld_protect_name => mld_zprecaply implicit none @@ -120,7 +120,7 @@ subroutine mld_zprecaply(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_zprecbld info=3112 call psb_errpush(info,name) goto 9999 @@ -140,7 +140,7 @@ subroutine mld_zprecaply(prec,x,y,desc_data,info,trans,work) ! Number of levels = 1: apply the base preconditioner ! call prec%precv(1)%sm%apply(zone,x,zzero,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_zprecaply subroutine mld_zprecaply1(prec,x,desc_data,info,trans) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zprecaply1 + use mld_z_inner_mod, mld_protect_name => mld_zprecaply1 implicit none diff --git a/mlprec/mld_zprecbld.f90 b/mlprec/mld_zprecbld.f90 index c27f385b..f60830b1 100644 --- a/mlprec/mld_zprecbld.f90 +++ b/mlprec/mld_zprecbld.f90 @@ -61,12 +61,8 @@ subroutine mld_zprecbld(a,desc_a,p,info) use psb_sparse_mod - use mld_inner_mod - use mld_prec_mod, mld_protect_name => mld_zprecbld - use mld_z_jac_smoother - use mld_z_as_smoother - use mld_z_diag_solver - use mld_z_ilu_solver + use mld_z_inner_mod + use mld_z_prec_mod, mld_protect_name => mld_zprecbld Implicit None @@ -84,6 +80,7 @@ subroutine mld_zprecbld(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 @@ -156,17 +153,8 @@ subroutine mld_zprecbld(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_zprecbld(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_z_jac_smoother_type :: p%precv(1)%sm, stat=info) - case(mld_as_) - allocate(mld_z_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_z_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_z_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_zprecbld(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_zprecbld(a,desc_a,p,info) end if return -contains - - subroutine init_baseprec_av(p,info) - type(mld_zbaseprec_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_zprecbld diff --git a/mlprec/mld_zprecinit.F90 b/mlprec/mld_zprecinit.F90 index 0913e7d5..86b71480 100644 --- a/mlprec/mld_zprecinit.F90 +++ b/mlprec/mld_zprecinit.F90 @@ -91,11 +91,18 @@ subroutine mld_zprecinit(p,ptype,info,nlev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_zprecinit + use mld_z_prec_mod, mld_protect_name => mld_zprecinit use mld_z_jac_smoother use mld_z_as_smoother + use mld_z_id_solver use mld_z_diag_solver use mld_z_ilu_solver +#if defined(HAVE_UMF_) + use mld_z_umf_solver +#endif +#if defined(HAVE_SLU_) + use mld_z_slu_solver +#endif implicit none @@ -119,104 +126,41 @@ subroutine mld_zprecinit(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_z_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_z_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_z_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_z_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_z_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_z_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_z_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_z_ilu_solver_type :: p%precv(ilev_)%sm%sv, stat=info) + call p%precv(ilev_)%default() case ('ML') @@ -228,105 +172,36 @@ subroutine mld_zprecinit(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_z_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 - if (nlev_ == 1) return + allocate(mld_z_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_z_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_z_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_z_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_SLU_) + allocate(mld_z_slu_solver_type :: p%precv(ilev_)%sm%sv, stat=info) #else - p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ + allocate(mld_z_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 + 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,'"' diff --git a/mlprec/mld_zprecset.F90 b/mlprec/mld_zprecset.F90 index b6d6ad52..5fb377e8 100644 --- a/mlprec/mld_zprecset.F90 +++ b/mlprec/mld_zprecset.F90 @@ -80,11 +80,22 @@ subroutine mld_zprecseti(p,what,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_zprecseti + use mld_z_prec_mod, mld_protect_name => mld_zprecseti + use mld_z_jac_smoother + use mld_z_as_smoother + use mld_z_id_solver + use mld_z_diag_solver + use mld_z_ilu_solver +#if defined(HAVE_UMF_) + use mld_z_umf_solver +#endif +#if defined(HAVE_SLU_) + use mld_z_slu_solver +#endif implicit none -! Arguments + ! Arguments type(mld_zprec_type), intent(inout) :: p integer, intent(in) :: what integer, intent(in) :: val @@ -99,7 +110,8 @@ subroutine mld_zprecseti(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) @@ -112,21 +124,9 @@ subroutine mld_zprecseti(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. @@ -138,37 +138,44 @@ subroutine mld_zprecseti(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' @@ -177,16 +184,32 @@ subroutine mld_zprecseti(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_UMF_) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif 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 @@ -194,14 +217,15 @@ subroutine mld_zprecseti(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 @@ -215,82 +239,94 @@ subroutine mld_zprecseti(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_UMF_) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info) +#elif 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 @@ -298,8 +334,336 @@ subroutine mld_zprecseti(p,what,val,info,ilev) endif +contains + + subroutine onelev_set_smoother(level,val,info) + type(mld_zonelev_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_z_base_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_z_base_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_z_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_base_smoother_type ::& + & level%sm, stat=info) + if (info ==0) allocate(mld_z_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_z_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_z_jac_smoother_type :: & + & level%sm, stat=info) + if (info == 0) allocate(mld_z_diag_solver_type :: & + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_z_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_z_jac_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_z_jac_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_z_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_jac_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_z_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_z_as_smoother_type) + ! do nothing + class default + call level%sm%free(info) + if (info == 0) deallocate(level%sm) + if (info == 0) allocate(mld_z_as_smoother_type ::& + & level%sm, stat=info) + if (info == 0) allocate(mld_z_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_as_smoother_type :: level%sm, stat=info) + if (info == 0) allocate(mld_z_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_zonelev_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_z_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_z_id_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_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_z_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_z_diag_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_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_z_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_z_ilu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_ilu_solver_type :: level%sm%sv, stat=info) + endif +#ifdef HAVE_UMF_ + case (mld_umf_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_z_umf_solver_type) + ! do nothing + class default + call level%sm%sv%free(info) + if (info == 0) deallocate(level%sm%sv) + if (info == 0) allocate(mld_z_umf_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_umf_solver_type :: level%sm%sv, stat=info) + endif +#endif +#ifdef HAVE_SLU_ + case (mld_slu_) + if (allocated(level%sm%sv)) then + select type (sv => level%sm%sv) + class is (mld_z_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_z_slu_solver_type ::& + & level%sm%sv, stat=info) + end select + else + allocate(mld_z_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_zprecseti +subroutine mld_zprecsetsm(p,val,info,ilev) + + use psb_sparse_mod + use mld_z_prec_mod, mld_protect_name => mld_zprecsetsm + + implicit none + + ! Arguments + type(mld_zprec_type), intent(inout) :: p + class(mld_z_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_zprecsetsm + +subroutine mld_zprecsetsv(p,val,info,ilev) + + use psb_sparse_mod + use mld_z_prec_mod, mld_protect_name => mld_zprecsetsv + + implicit none + + ! Arguments + type(mld_zprec_type), intent(inout) :: p + class(mld_z_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_zprecsetsv + ! ! Subroutine: mld_zprecsetc ! Version: complex @@ -343,7 +707,7 @@ end subroutine mld_zprecseti subroutine mld_zprecsetc(p,what,string,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_zprecsetc + use mld_z_prec_mod, mld_protect_name => mld_zprecsetc implicit none @@ -377,12 +741,6 @@ subroutine mld_zprecsetc(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) @@ -434,7 +792,7 @@ end subroutine mld_zprecsetc subroutine mld_zprecsetr(p,what,val,info,ilev) use psb_sparse_mod - use mld_prec_mod, mld_protect_name => mld_zprecsetr + use mld_z_prec_mod, mld_protect_name => mld_zprecsetr implicit none @@ -458,22 +816,19 @@ subroutine mld_zprecsetr(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. @@ -486,7 +841,8 @@ subroutine mld_zprecsetr(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 @@ -495,9 +851,9 @@ subroutine mld_zprecsetr(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 @@ -512,38 +868,20 @@ subroutine mld_zprecsetr(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' diff --git a/mlprec/mld_zslu_bld.f90 b/mlprec/mld_zslu_bld.f90 index 4a8d1c84..c9c11e32 100644 --- a/mlprec/mld_zslu_bld.f90 +++ b/mlprec/mld_zslu_bld.f90 @@ -72,7 +72,7 @@ subroutine mld_zslu_bld(a,desc_a,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zslu_bld + use mld_z_inner_mod, mld_protect_name => mld_zslu_bld implicit none diff --git a/mlprec/mld_zslu_interface.c b/mlprec/mld_zslu_interface.c index e96a1853..a104321c 100644 --- a/mlprec/mld_zslu_interface.c +++ b/mlprec/mld_zslu_interface.c @@ -115,51 +115,15 @@ typedef struct { #endif -#ifdef LowerUndescore -#define mld_zslu_fact_ mld_zslu_fact_ -#define mld_zslu_solve_ mld_zslu_solve_ -#define mld_zslu_free_ mld_zslu_free_ -#endif -#ifdef LowerDoubleUndescore -#define mld_zslu_fact_ mld_zslu_fact__ -#define mld_zslu_solve_ mld_zslu_solve__ -#define mld_zslu_free_ mld_zslu_free__ -#endif -#ifdef LowerCase -#define mld_zslu_fact_ mld_zslu_fact -#define mld_zslu_solve_ mld_zslu_solve -#define mld_zslu_free_ mld_zslu_free -#endif -#ifdef UpperUndescore -#define mld_zslu_fact_ MLD_ZSLU_FACT_ -#define mld_zslu_solve_ MLD_ZSLU_SOLVE_ -#define mld_zslu_free_ MLD_ZSLU_FREE_ -#endif -#ifdef UpperDoubleUndescore -#define mld_zslu_fact_ MLD_ZSLU_FACT__ -#define mld_zslu_solve_ MLD_ZSLU_SOLVE__ -#define mld_zslu_free_ MLD_ZSLU_FREE__ -#endif -#ifdef UpperCase -#define mld_zslu_fact_ MLD_ZSLU_FACT -#define mld_zslu_solve_ MLD_ZSLU_SOLVE -#define mld_zslu_free_ MLD_ZSLU_FREE -#endif - - - -void -mld_zslu_fact_(int *n, int *nnz, -#ifdef Have_SLU_ - doublecomplex *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_zslu_fact(int n, int nnz, +#ifdef HAVE_SLU_ + doublecomplex *values, +#else + void *values, #endif - int *info) + int *rowptr, int *colind, void **f_factors) { /* @@ -173,7 +137,7 @@ mld_zslu_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_zslu_fact_(int *n, int *nnz, superlu_options_t options; SuperLUStat_t stat; factors_t *LUfactors; + int info; trans = NOTRANS; @@ -197,17 +162,13 @@ mld_zslu_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]; - - zCreate_CompRow_Matrix(&A, *n, *n, *nnz, values, colind, rowptr, + zCreate_CompRow_Matrix(&A, n, n, nnz, values, colind, rowptr, SLU_NR, SLU_Z, 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_zslu_fact_(int *n, int *nnz, relax = sp_ienv(2); zgstrf(&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; zQuerySpace(L, U, &mem_usage); @@ -241,8 +202,8 @@ mld_zslu_fact_(int *n, int *nnz, mem_usage.expansions); #endif } else { - printf("dgstrf() error returns INFO= %d\n", *info); - if ( *info <= *n ) { /* factorization completes */ + printf("zgstrf() error returns INFO= %d\n", info); + if ( info <= n ) { /* factorization completes */ zQuerySpace(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_zslu_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_zslu_solve_(int *itrans, int *n, int *nrhs, -#ifdef Have_SLU_ - doublecomplex *b, int *ldb, - fptr *f_factors, /* a handle containing the address - pointing to the factored matrices */ -#else - void *b, int *ldb, - void *f_factors, +int +mld_zslu_solve(int itrans, int n, int nrhs, +#ifdef HAVE_SLU_ + doublecomplex *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_zslu_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_zslu_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; - zCreate_Dense_Matrix(&B, *n, *nrhs, b, *ldb, SLU_DN, SLU_Z, SLU_GE); + zCreate_Dense_Matrix(&B, n, nrhs, b, ldb, SLU_DN, SLU_Z, SLU_GE); /* Solve the system A*X=B, overwriting B with X. */ - zgstrs (trans, L, U, perm_c, perm_r, &B, &stat, info); + zgstrs (trans, L, U, perm_c, perm_r, &B, &stat, &info); if (info != 0) { if (B.Stype != SLU_DN) fprintf(stderr,"zgstrs error kind 1: SLU_DN\n"); if (B.Dtype != SLU_Z) fprintf(stderr,"zgstrs error kind 2: SLU_Z\n"); @@ -339,22 +295,15 @@ mld_zslu_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_zslu_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_zslu_free(void *f_factors) { /* @@ -364,24 +313,11 @@ mld_zslu_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; - double 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_zslu_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 } diff --git a/mlprec/mld_zslud_bld.f90 b/mlprec/mld_zslud_bld.f90 index 2a2ffb08..c2957a4e 100644 --- a/mlprec/mld_zslud_bld.f90 +++ b/mlprec/mld_zslud_bld.f90 @@ -69,7 +69,7 @@ subroutine mld_zsludist_bld(a,desc_a,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zsludist_bld + use mld_z_inner_mod, mld_protect_name => mld_zsludist_bld implicit none diff --git a/mlprec/mld_zsp_renum.f90 b/mlprec/mld_zsp_renum.f90 index fcc0e611..4bdd0751 100644 --- a/mlprec/mld_zsp_renum.f90 +++ b/mlprec/mld_zsp_renum.f90 @@ -84,7 +84,7 @@ subroutine mld_zsp_renum(a,blck,p,atmp,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zsp_renum + use mld_z_inner_mod, mld_protect_name => mld_zsp_renum implicit none diff --git a/mlprec/mld_zumf_bld.f90 b/mlprec/mld_zumf_bld.f90 index 5be0fbec..6fb6d5d9 100644 --- a/mlprec/mld_zumf_bld.f90 +++ b/mlprec/mld_zumf_bld.f90 @@ -78,7 +78,7 @@ subroutine mld_zumf_bld(a,desc_a,p,info) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_zumf_bld + use mld_z_inner_mod, mld_protect_name => mld_zumf_bld implicit none diff --git a/tests/newslv/Makefile b/tests/newslv/Makefile new file mode 100644 index 00000000..a2e81269 --- /dev/null +++ b/tests/newslv/Makefile @@ -0,0 +1,39 @@ +MLDDIR=../.. +include $(MLDDIR)/Make.inc +include $(MLDDIR)/Make.inc +PSBLIBDIR=$(PSBLASDIR)/lib/ +PSBINCDIR=$(PSBLASDIR)/include +MLDLIBDIR=$(MLDDIR)/lib +MLD_LIB=-L$(MLDLIBDIR) -lpsb_krylov -lmld_prec -lpsb_prec +PSBLAS_LIB= -L$(PSBLIBDIR) -lpsb_util -lpsb_base +FINCLUDES=$(FMFLAG). $(FMFLAG)$(MLDLIBDIR) $(FMFLAG)$(PSBINCDIR) $(FIFLAG). + +PDOBJS=ppde.o data_input.o mld_d_tlu_solver.o +PSOBJS=spde.o data_input.o +EXEDIR=./runs + +all: ppde spde + +ppde: $(PDOBJS) + $(F90LINK) $(PDOBJS) -o ppde $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) + /bin/mv ppde $(EXEDIR) + + +spde: $(PSOBJS) + $(F90LINK) $(PSOBJS) -o spde $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) + /bin/mv spde $(EXEDIR) + +ppde.o spde.o: data_input.o +ppde.o: mld_d_tlu_solver.o + + +clean: + /bin/rm -f $(PDOBJS) $(EXEDIR)/ppde $(PSOBJS) $(EXEDIR)/spde + +verycleanlib: + (cd ../..; make veryclean) +lib: + (cd ../../; make library) + + + diff --git a/tests/newslv/data_input.f90 b/tests/newslv/data_input.f90 new file mode 100644 index 00000000..ef3322d7 --- /dev/null +++ b/tests/newslv/data_input.f90 @@ -0,0 +1,187 @@ +!!$ +!!$ +!!$ 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. +!!$ +!!$ +module data_input + + interface read_data + module procedure read_char, read_int,& + & read_double, read_single,& + & string_read_char, string_read_int,& + & string_read_double, string_read_single + end interface read_data + interface trim_string + module procedure trim_string + end interface + + character(len=4096), private :: charbuf + character, private, parameter :: def_marker="!" + +contains + + subroutine read_char(val,file,marker) + character(len=*), intent(out) :: val + integer, intent(in) :: file + character(len=1), optional, intent(in) :: marker + + read(file,'(a)')charbuf + call read_data(val,charbuf,marker) + + end subroutine read_char + + subroutine read_int(val,file,marker) + integer, intent(out) :: val + integer, intent(in) :: file + character(len=1), optional, intent(in) :: marker + + read(file,'(a)')charbuf + call read_data(val,charbuf,marker) + + end subroutine read_int + subroutine read_single(val,file,marker) + use psb_sparse_mod + real(psb_spk_), intent(out) :: val + integer, intent(in) :: file + character(len=1), optional, intent(in) :: marker + + read(file,'(a)')charbuf + call read_data(val,charbuf,marker) + + end subroutine read_single + subroutine read_double(val,file,marker) + use psb_sparse_mod + real(psb_dpk_), intent(out) :: val + integer, intent(in) :: file + character(len=1), optional, intent(in) :: marker + + read(file,'(a)')charbuf + call read_data(val,charbuf,marker) + + end subroutine read_double + + subroutine string_read_char(val,file,marker) + character(len=*), intent(out) :: val + character(len=*), intent(in) :: file + character(len=1), optional, intent(in) :: marker + character(len=1) :: marker_ + character(len=1024) :: charbuf + integer :: idx + if (present(marker)) then + marker_ = marker + else + marker_ = def_marker + end if + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,marker_) + if (idx == 0) idx = len(charbuf)+1 + read(charbuf(1:idx-1),'(a)') val + end subroutine string_read_char + + subroutine string_read_int(val,file,marker) + integer, intent(out) :: val + character(len=*), intent(in) :: file + character(len=1), optional, intent(in) :: marker + character(len=1) :: marker_ + character(len=1024) :: charbuf + integer :: idx + if (present(marker)) then + marker_ = marker + else + marker_ = def_marker + end if + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,marker_) + if (idx == 0) idx = len(charbuf)+1 + read(charbuf(1:idx-1),*) val + end subroutine string_read_int + subroutine string_read_single(val,file,marker) + use psb_sparse_mod + real(psb_spk_), intent(out) :: val + character(len=*), intent(in) :: file + character(len=1), optional, intent(in) :: marker + character(len=1) :: marker_ + character(len=1024) :: charbuf + integer :: idx + if (present(marker)) then + marker_ = marker + else + marker_ = def_marker + end if + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,marker_) + if (idx == 0) idx = len(charbuf)+1 + read(charbuf(1:idx-1),*) val + end subroutine string_read_single + subroutine string_read_double(val,file,marker) + use psb_sparse_mod + real(psb_dpk_), intent(out) :: val + character(len=*), intent(in) :: file + character(len=1), optional, intent(in) :: marker + character(len=1) :: marker_ + character(len=1024) :: charbuf + integer :: idx + if (present(marker)) then + marker_ = marker + else + marker_ = def_marker + end if + read(file,'(a)')charbuf + charbuf = adjustl(charbuf) + idx=index(charbuf,marker_) + if (idx == 0) idx = len(charbuf)+1 + read(charbuf(1:idx-1),*) val + end subroutine string_read_double + + function trim_string(string,marker) + character(len=*), intent(in) :: string + character(len=1), optional, intent(in) :: marker + character(len=len(string)) :: trim_string + character(len=1) :: marker_ + integer :: idx + if (present(marker)) then + marker_ = marker + else + marker_ = def_marker + end if + idx=index(string,marker_) + trim_string = adjustl(string(idx:)) + end function trim_string +end module data_input + diff --git a/tests/newslv/mld_d_tlu_solver.f90 b/tests/newslv/mld_d_tlu_solver.f90 new file mode 100644 index 00000000..88e429fa --- /dev/null +++ b/tests/newslv/mld_d_tlu_solver.f90 @@ -0,0 +1,729 @@ +!!$ +!!$ +!!$ 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_tlu_solver + + use mld_d_prec_type + + type, extends(mld_d_base_solver_type) :: mld_d_tlu_solver_type + type(psb_dspmat_type) :: l, u + real(psb_dpk_), allocatable :: d(:) + integer :: fact_type, fill_in + real(psb_dpk_) :: thresh + contains + procedure, pass(sv) :: dump => d_tlu_solver_dmp + procedure, pass(sv) :: build => d_tlu_solver_bld + procedure, pass(sv) :: apply => d_tlu_solver_apply + procedure, pass(sv) :: free => d_tlu_solver_free + procedure, pass(sv) :: seti => d_tlu_solver_seti + procedure, pass(sv) :: setc => d_tlu_solver_setc + procedure, pass(sv) :: setr => d_tlu_solver_setr + procedure, pass(sv) :: descr => d_tlu_solver_descr + procedure, pass(sv) :: sizeof => d_tlu_solver_sizeof + procedure, pass(sv) :: default => d_tlu_solver_default + end type mld_d_tlu_solver_type + + + private :: d_tlu_solver_bld, d_tlu_solver_apply, & + & d_tlu_solver_free, d_tlu_solver_seti, & + & d_tlu_solver_setc, d_tlu_solver_setr,& + & d_tlu_solver_descr, d_tlu_solver_sizeof, & + & d_tlu_solver_default, d_tlu_solver_dmp + + + interface mld_ilu0_fact + subroutine mld_dilu0_fact(ialg,a,l,u,d,info,blck,upd) + use psb_sparse_mod, only : psb_dspmat_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 + end interface + + interface mld_iluk_fact + subroutine mld_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) + use psb_sparse_mod, only : psb_dspmat_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 + end interface + + interface mld_ilut_fact + subroutine mld_dilut_fact(fill_in,thres,a,l,u,d,info,blck) + use psb_sparse_mod, only : psb_dspmat_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 + end interface + + character(len=15), parameter, private :: & + & fact_names(0:mld_slv_delta_+4)=(/& + & 'none ','none ',& + & 'none ','none ',& + & 'none ','DIAG ?? ',& + & 'ILU(n) ',& + & 'MILU(n) ','ILU(t,n) '/) + + +contains + + subroutine d_tlu_solver_default(sv) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_d_tlu_solver_type), intent(inout) :: sv + + sv%fact_type = mld_ilu_n_ + sv%fill_in = 0 + sv%thresh = dzero + + return + end subroutine d_tlu_solver_default + + subroutine d_tlu_solver_check(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_d_tlu_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_tlu_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_tlu_solver_check + + + subroutine d_tlu_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_tlu_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_tlu_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) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + + select case(trans_) + case('N') + call psb_spsm(done,sv%l,x,dzero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux) + + if (info == psb_success_) call psb_spsm(alpha,sv%u,ww,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T','C') + call psb_spsm(done,sv%u,x,dzero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux) + if (info == psb_success_) call psb_spsm(alpha,sv%l,ww,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + 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_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine d_tlu_solver_apply + + subroutine d_tlu_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_tlu_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_tlu_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) + + if (psb_toupper(upd) == 'F') then + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + if (present(b)) then + nztota = nztota + b%get_nzeros() + end if + + call sv%l%csall(n_row,n_row,info,nztota) + if (info == psb_success_) call sv%u%csall(n_row,n_row,info,nztota) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(sv%d)) then + if (size(sv%d) < n_row) then + deallocate(sv%d) + endif + endif + if (.not.allocated(sv%d)) then + allocate(sv%d(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + endif + + + select case(sv%fact_type) + + case (mld_ilu_t_) + ! + ! ILU(k,t) + ! + 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/)) + goto 9999 + + case(0:) + ! Fill-in >= 0 + call mld_ilut_fact(sv%fill_in,sv%thresh,& + & a, sv%l,sv%u,sv%d,info,blck=b) + end select + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mld_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(mld_ilu_n_,mld_milu_n_) + ! + ! ILU(k) and MILU(k) + ! + select case(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/)) + goto 9999 + case(0) + ! Fill-in 0 + ! Separate implementation of ILU(0) for better performance. + ! There seems to be a problem with the separate implementation of MILU(0), + ! contained into mld_ilu0_fact. This must be investigated. For the time being, + ! resort to the implementation of MILU(k) with k=0. + if (sv%fact_type == mld_ilu_n_) then + call mld_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + & sv%d,info,blck=b,upd=upd) + else + call mld_iluk_fact(sv%fill_in,sv%fact_type,& + & a,sv%l,sv%u,sv%d,info,blck=b) + endif + case(1:) + ! Fill-in >= 1 + ! The same routine implements both ILU(k) and MILU(k) + call mld_iluk_fact(sv%fill_in,sv%fact_type,& + & a,sv%l,sv%u,sv%d,info,blck=b) + end select + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mld_iluk_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case default + ! If we end up here, something was wrong up in the call chain. + 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 + else + ! 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) + goto 9999 + + ! + ! What is an update of a factorization?? + ! A first attempt could be to reuse EXACTLY the existing indices + ! as if it was an ILU(0) (since, effectively, the sparsity pattern + ! should not grow beyond what is already there). + ! + call mld_ilu0_fact(sv%fact_type,a,& + & sv%l,sv%u,& + & sv%d,info,blck=b,upd=upd) + + end if + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + 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_tlu_solver_bld + + + subroutine d_tlu_solver_seti(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_d_tlu_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_tlu_solver_seti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(what) + case(mld_sub_solve_) + sv%fact_type = val + case(mld_sub_fillin_) + sv%fill_in = val + 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_tlu_solver_seti + + subroutine d_tlu_solver_setc(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_d_tlu_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_tlu_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_tlu_solver_setc + + subroutine d_tlu_solver_setr(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_d_tlu_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_tlu_solver_setr' + + call psb_erractionsave(err_act) + info = psb_success_ + + select case(what) + case(mld_sub_iluthrs_) + sv%thresh = val + 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_tlu_solver_setr + + subroutine d_tlu_solver_free(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_d_tlu_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_tlu_solver_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(sv%d)) then + deallocate(sv%d,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call sv%l%free() + call sv%u%free() + + 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_tlu_solver_free + + subroutine d_tlu_solver_descr(sv,info,iout,coarse) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_d_tlu_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_tlu_solver_descr' + integer :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + write(iout_,*) ' TLU: test a new solver kind' + write(iout_,*) ' Incomplete factorization solver: ',& + & fact_names(sv%fact_type) + select case(sv%fact_type) + case(mld_ilu_n_,mld_milu_n_) + write(iout_,*) ' Fill level:',sv%fill_in + case(mld_ilu_t_) + write(iout_,*) ' Fill level:',sv%fill_in + write(iout_,*) ' Fill threshold :',sv%thresh + 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_tlu_solver_descr + + function d_tlu_solver_sizeof(sv) result(val) + use psb_sparse_mod + implicit none + ! Arguments + class(mld_d_tlu_solver_type), intent(in) :: sv + integer(psb_long_int_k_) :: val + integer :: i + + 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 d_tlu_solver_sizeof + + subroutine d_tlu_solver_dmp(sv,ictxt,level,info,prefix,head,solver) + use psb_sparse_mod + implicit none + class(mld_d_tlu_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 d_tlu_solver_dmp + + +end module mld_d_tlu_solver diff --git a/tests/newslv/ppde.f90 b/tests/newslv/ppde.f90 new file mode 100644 index 00000000..4e51f32e --- /dev/null +++ b/tests/newslv/ppde.f90 @@ -0,0 +1,751 @@ +!!$ +!!$ +!!$ 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: ppde.f90 +! +! Program: ppde +! This sample program solves a linear system obtained by discretizing a +! PDE with Dirichlet BCs. +! +! +! The PDE is a general second order equation in 3d +! +! b1 dd(u) b2 dd(u) b3 dd(u) a1 d(u) a2 d(u) a3 d(u) +! - ------ - ------ - ------ - ----- - ------ - ------ + a4 u = 0 +! dxdx dydy dzdz dx dy dz +! +! with Dirichlet boundary conditions, on the unit cube 0<=x,y,z<=1. +! +! Example taken from: +! C.T.Kelley +! Iterative Methods for Linear and Nonlinear Equations +! SIAM 1995 +! +! In this sample program the index space of the discretized +! computational domain is first numbered sequentially in a standard way, +! then the corresponding vector is distributed according to a BLOCK +! data distribution. +! +! Boundary conditions are set in a very simple way, by adding +! equations of the form +! +! u(x,y) = exp(-x^2-y^2-z^2) +! +! Note that if a1=a2=a3=a4=0., the PDE is the well-known Laplace equation. +! +program ppde + use psb_sparse_mod + use mld_prec_mod + use psb_krylov_mod + use psb_util_mod + use data_input + use mld_d_tlu_solver + implicit none + + ! input parameters + character(len=20) :: kmethd, ptype + character(len=5) :: afmt + integer :: idim + + ! miscellaneous + real(psb_dpk_), parameter :: one = 1.d0 + real(psb_dpk_) :: t1, t2, tprec + + ! sparse matrix and preconditioner + type(psb_dspmat_type) :: a + type(mld_dprec_type) :: prec + type(mld_d_tlu_solver_type) :: tlusv + ! descriptor + type(psb_desc_type) :: desc_a + ! dense matrices + real(psb_dpk_), allocatable :: b(:), x(:) + ! blacs parameters + integer :: ictxt, iam, np + + ! solver parameters + integer :: iter, itmax,itrace, istopc, irst, nlv + integer(psb_long_int_k_) :: amatsize, precsize, descsize + real(psb_dpk_) :: err, eps + + type precdata + character(len=20) :: descr ! verbose description of the prec + character(len=10) :: prec ! overall prectype + integer :: novr ! number of overlap layers + integer :: jsweeps ! Jacobi/smoother sweeps + character(len=16) :: restr ! restriction over application of as + character(len=16) :: prol ! prolongation over application of as + character(len=16) :: solve ! Solver type: ILU, SuperLU, UMFPACK. + integer :: fill1 ! Fill-in for factorization 1 + real(psb_dpk_) :: thr1 ! Threshold for fact. 1 ILU(T) + character(len=16) :: smther ! Smoother + integer :: nlev ! Number of levels in multilevel prec. + character(len=16) :: aggrkind ! smoothed/raw aggregatin + character(len=16) :: aggr_alg ! local or global aggregation + character(len=16) :: mltype ! additive or multiplicative 2nd level prec + character(len=16) :: smthpos ! side: pre, post, both smoothing + character(len=16) :: cmat ! coarse mat + character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist + character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. + integer :: cfill ! Fill-in for factorization 1 + real(psb_dpk_) :: cthres ! Threshold for fact. 1 ILU(T) + integer :: cjswp ! Jacobi sweeps + real(psb_dpk_) :: athres ! smoother aggregation threshold + end type precdata + type(precdata) :: prectype + ! other variables + integer :: info + character(len=20) :: name,ch_err + + info=psb_success_ + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='pde90' + call psb_set_errverbosity(2) + + + ! + ! get parameters + ! + call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + + ! + ! allocate and fill in the coefficient matrix, rhs and initial guess + ! + + call psb_barrier(ictxt) + t1 = psb_wtime() + call create_matrix(idim,a,b,x,desc_a,ictxt,afmt,info) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='create_matrix' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == psb_root_) write(*,'("Overall matrix creation time : ",es12.5)')t2 + if (iam == psb_root_) write(*,'(" ")') + ! + ! prepare the preconditioner. + ! + + if (psb_toupper(prectype%prec) == 'ML') then + nlv = prectype%nlev + call mld_precinit(prec,prectype%prec, info, nlev=nlv) + call mld_precset(prec,mld_smoother_type_, prectype%smther, info) + call mld_precset(prec,mld_smoother_sweeps_, prectype%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prectype%novr, info) + call mld_precset(prec,mld_sub_restr_, prectype%restr, info) + call mld_precset(prec,mld_sub_prol_, prectype%prol, info) + call mld_precset(prec,mld_sub_solve_, prectype%solve, info) + call mld_precset(prec,mld_sub_fillin_, prectype%fill1, info) + call mld_precset(prec,mld_sub_iluthrs_, prectype%thr1, info) + call mld_precset(prec,mld_aggr_kind_, prectype%aggrkind,info) + call mld_precset(prec,mld_aggr_alg_, prectype%aggr_alg,info) + call mld_precset(prec,mld_ml_type_, prectype%mltype, info) + call mld_precset(prec,mld_smoother_pos_, prectype%smthpos, info) + call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info) + call mld_precset(prec,mld_coarse_solve_, prectype%csolve, info) + call mld_precset(prec,mld_coarse_subsolve_, prectype%csbsolve,info) + call mld_precset(prec,mld_coarse_mat_, prectype%cmat, info) + call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) + call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) + call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + else + nlv = 1 + call mld_precinit(prec,prectype%prec, info, nlev=nlv) + call mld_precset(prec,mld_smoother_sweeps_, prectype%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prectype%novr, info) + call mld_precset(prec,mld_sub_restr_, prectype%restr, info) + call mld_precset(prec,mld_sub_prol_, prectype%prol, info) + call mld_precset(prec,mld_sub_solve_, prectype%solve, info) + call mld_precset(prec,mld_sub_fillin_, prectype%fill1, info) + call mld_precset(prec,mld_sub_iluthrs_, prectype%thr1, info) + end if + call mld_inner_precset(prec,tlusv,info,ilev=nlv) + + call psb_barrier(ictxt) + t1 = psb_wtime() + call mld_precbld(a,desc_a,prec,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_precbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + tprec = psb_wtime()-t1 + + call psb_amx(ictxt,tprec) + + if (iam == psb_root_) write(*,'("Preconditioner time : ",es12.5)')tprec + if (iam == psb_root_) call mld_precdescr(prec,info) + if (iam == psb_root_) write(*,'(" ")') + + ! + ! iterative method parameters + ! + if(iam == psb_root_) write(*,'("Calling iterative method ",a)')kmethd + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_krylov(kmethd,a,prec,b,x,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='solver routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + call psb_amx(ictxt,t2) + + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + precsize = mld_sizeof(prec) + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam == psb_root_) then + write(*,'(" ")') + write(*,'("Time to solve matrix : ",es12.5)')t2 + write(*,'("Time per iteration : ",es12.5)')t2/iter + write(*,'("Number of iterations : ",i0)')iter + write(*,'("Convergence indicator on exit : ",es12.5)')err + write(*,'("Info on exit : ",i0)')info + write(*,'("Total memory occupation for A: ",i12)')amatsize + write(*,'("Total memory occupation for DESC_A: ",i12)')descsize + write(*,'("Total memory occupation for PREC: ",i12)')precsize + end if + + ! + ! cleanup storage and exit + ! + call psb_gefree(b,desc_a,info) + call psb_gefree(x,desc_a,info) + call psb_spfree(a,desc_a,info) + call mld_precfree(prec,info) + call psb_cdfree(desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + +9999 continue + if(info /= psb_success_) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + integer :: ictxt + type(precdata) :: prectype + character(len=*) :: kmethd, afmt + integer :: idim, istopc,itmax,itrace,irst + integer :: np, iam, info + real(psb_dpk_) :: eps + character(len=20) :: buffer + + call psb_info(ictxt, iam, np) + + if (iam == psb_root_) then + call read_data(kmethd,5) + call read_data(afmt,5) + call read_data(idim,5) + call read_data(istopc,5) + call read_data(itmax,5) + call read_data(itrace,5) + call read_data(irst,5) + call read_data(eps,5) + call read_data(prectype%descr,5) ! verbose description of the prec + call read_data(prectype%prec,5) ! overall prectype + call read_data(prectype%novr,5) ! number of overlap layers + call read_data(prectype%restr,5) ! restriction over application of as + call read_data(prectype%prol,5) ! prolongation over application of as + call read_data(prectype%solve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%fill1,5) ! Fill-in for factorization 1 + call read_data(prectype%thr1,5) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%jsweeps,5) ! Jacobi sweeps for PJAC + if (psb_toupper(prectype%prec) == 'ML') then + call read_data(prectype%smther,5) ! Smoother type. + call read_data(prectype%nlev,5) ! Number of levels in multilevel prec. + call read_data(prectype%aggrkind,5) ! smoothed/raw aggregatin + call read_data(prectype%aggr_alg,5) ! local or global aggregation + call read_data(prectype%mltype,5) ! additive or multiplicative 2nd level prec + call read_data(prectype%smthpos,5) ! side: pre, post, both smoothing + call read_data(prectype%cmat,5) ! coarse mat + call read_data(prectype%csolve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%csbsolve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%cfill,5) ! Fill-in for factorization 1 + call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%cjswp,5) ! Jacobi sweeps + call read_data(prectype%athres,5) ! smoother aggr thresh + end if + end if + + ! broadcast parameters to all processors + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,afmt) + call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,istopc) + call psb_bcast(ictxt,itmax) + call psb_bcast(ictxt,itrace) + call psb_bcast(ictxt,irst) + call psb_bcast(ictxt,eps) + + + call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec + call psb_bcast(ictxt,prectype%prec) ! overall prectype + call psb_bcast(ictxt,prectype%novr) ! number of overlap layers + call psb_bcast(ictxt,prectype%restr) ! restriction over application of as + call psb_bcast(ictxt,prectype%prol) ! prolongation over application of as + call psb_bcast(ictxt,prectype%solve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%fill1) ! Fill-in for factorization 1 + call psb_bcast(ictxt,prectype%thr1) ! Threshold for fact. 1 ILU(T) + call psb_bcast(ictxt,prectype%jsweeps) ! Jacobi sweeps + if (psb_toupper(prectype%prec) == 'ML') then + call psb_bcast(ictxt,prectype%smther) ! Smoother type. + call psb_bcast(ictxt,prectype%nlev) ! Number of levels in multilevel prec. + call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/raw aggregatin + call psb_bcast(ictxt,prectype%aggr_alg) ! local or global aggregation + call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec + call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing + call psb_bcast(ictxt,prectype%cmat) ! coarse mat + call psb_bcast(ictxt,prectype%csolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%csbsolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%cfill) ! Fill-in for factorization 1 + call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) + call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps + call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + end if + + if (iam == psb_root_) then + write(*,'("Solving matrix : ell1")') + write(*,'("Grid dimensions : ",i4,"x",i4,"x",i4)')idim,idim,idim + write(*,'("Number of processors : ",i0)') np + write(*,'("Data distribution : BLOCK")') + write(*,'("Preconditioner : ",a)') prectype%descr + write(*,'("Iterative method : ",a)') kmethd + write(*,'(" ")') + endif + + return + + end subroutine get_parms + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer :: iout + write(iout,*)'incorrect parameter(s) found' + write(iout,*)' usage: pde90 methd prec dim & + &[istop itmax itrace]' + write(iout,*)' where:' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' prec : bjac diag none' + write(iout,*)' dim number of points along each axis' + write(iout,*)' the size of the resulting linear ' + write(iout,*)' system is dim**3' + write(iout,*)' istop stopping criterion 1, 2 ' + write(iout,*)' itmax maximum number of iterations [500] ' + write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' >= 1 do tracing every itrace' + write(iout,*)' iterations ' + end subroutine pr_usage + + ! + ! subroutine to allocate and fill in the coefficient matrix and + ! the rhs. + ! + subroutine create_matrix(idim,a,b,xv,desc_a,ictxt,afmt,info) + ! + ! discretize the partial diferential equation + ! + ! b1 dd(u) b2 dd(u) b3 dd(u) a1 d(u) a2 d(u) a3 d(u) + ! - ------ - ------ - ------ - ----- - ------ - ------ + a4 u + ! dxdx dydy dzdz dx dy dz + ! + ! with Dirichlet boundary conditions, on the unit cube 0<=x,y,z<=1. + ! + ! Boundary conditions are set in a very simple way, by adding + ! equations of the form + ! + ! u(x,y) = exp(-x^2-y^2-z^2) + ! + ! Note that if a1=a2=a3=a4=0., the PDE is the well-known Laplace equation. + ! + use psb_sparse_mod + implicit none + integer :: idim + integer, parameter :: nb=20 + real(psb_dpk_), allocatable :: b(:),xv(:) + type(psb_desc_type) :: desc_a + integer :: ictxt, info + character :: afmt*5 + type(psb_dspmat_type) :: a + real(psb_dpk_) :: zt(nb),x,y,z + integer :: m,n,nnz,glob_row,nlr,i,ii,ib,k + integer :: ix,iy,iz,ia,indx_owner + integer :: np, iam, nr, nt + integer :: element + integer, allocatable :: irow(:),icol(:),myidx(:) + real(psb_dpk_), allocatable :: val(:) + ! deltah dimension of each grid cell + ! deltat discretization time + real(psb_dpk_) :: deltah + real(psb_dpk_),parameter :: rhs=0.d0,one=1.d0,zero=0.d0 + real(psb_dpk_) :: t0, t1, t2, t3, tasb, talc, ttot, tgen + real(psb_dpk_) :: a1, a2, a3, a4, b1, b2, b3 + external :: a1, a2, a3, a4, b1, b2, b3 + integer :: err_act + + character(len=20) :: name, ch_err + + info = psb_success_ + name = 'create_matrix' + call psb_erractionsave(err_act) + + call psb_info(ictxt, iam, np) + + deltah = 1.d0/(idim-1) + + ! initialize array descriptor and sparse matrix storage. provide an + ! estimate of the number of non zeroes + + m = idim*idim*idim + n = m + nnz = ((n*9)/(np)) + if(iam == psb_root_) write(*,'("Generating Matrix (size=",i0,")...")')n + + ! + ! Using a simple BLOCK distribution. + ! + nt = (m+np-1)/np + nr = max(0,min(nt,m-(iam*nt))) + + nt = nr + call psb_sum(ictxt,nt) + if (nt /= m) write(0,*) iam, 'Initialization error ',nr,nt,m + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdall(ictxt,desc_a,info,nl=nr) + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) + ! define rhs from boundary conditions; also build initial guess + if (info == psb_success_) call psb_geall(b,desc_a,info) + if (info == psb_success_) call psb_geall(xv,desc_a,info) + nlr = psb_cd_get_local_rows(desc_a) + call psb_barrier(ictxt) + talc = psb_wtime()-t0 + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! we build an auxiliary matrix consisting of one row at a + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),myidx(nlr),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1,nlr + myidx(i) = i + end do + + + call psb_loc_to_glob(myidx,desc_a,info) + + ! loop over rows belonging to current process in a block + ! distribution. + + call psb_barrier(ictxt) + t1 = psb_wtime() + do ii=1, nlr,nb + ib = min(nb,nlr-ii+1) + element = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + if (mod(glob_row,(idim*idim)) == 0) then + ix = glob_row/(idim*idim) + else + ix = glob_row/(idim*idim)+1 + endif + if (mod((glob_row-(ix-1)*idim*idim),idim) == 0) then + iy = (glob_row-(ix-1)*idim*idim)/idim + else + iy = (glob_row-(ix-1)*idim*idim)/idim+1 + endif + iz = glob_row-(ix-1)*idim*idim-(iy-1)*idim + ! x, y, x coordinates + x = ix*deltah + y = iy*deltah + z = iz*deltah + + ! check on boundary points + zt(k) = 0.d0 + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + if (ix == 1) then + val(element)=-b1(x,y,z)-a1(x,y,z) + val(element) = val(element)/(deltah*& + & deltah) + zt(k) = exp(-y**2-z**2)*(-val(element)) + else + val(element)=-b1(x,y,z)-a1(x,y,z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element) = (ix-2)*idim*idim+(iy-1)*idim+(iz) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x,y-1,z) + if (iy == 1) then + val(element)=-b2(x,y,z)-a2(x,y,z) + val(element) = val(element)/(deltah*& + & deltah) + zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) + else + val(element)=-b2(x,y,z)-a2(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy-2)*idim+(iz) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x,y,z-1) + if (iz == 1) then + val(element)=-b3(x,y,z)-a3(x,y,z) + val(element) = val(element)/(deltah*deltah) + zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) + else + val(element)=-b3(x,y,z)-a3(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy-1)*idim+(iz-1) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x,y,z) + val(element)=2*b1(x,y,z) + 2*b2(x,y,z)& + & + 2*b3(x,y,z) + a1(x,y,z)& + & + a2(x,y,z) + a3(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy-1)*idim+(iz) + irow(element) = glob_row + element = element+1 + ! term depending on (x,y,z+1) + if (iz == idim) then + val(element)=-b1(x,y,z) + val(element) = val(element)/(deltah*deltah) + zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) + else + val(element)=-b1(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy-1)*idim+(iz+1) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x,y+1,z) + if (iy == idim) then + val(element)=-b2(x,y,z) + val(element) = val(element)/(deltah*deltah) + zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) + else + val(element)=-b2(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy)*idim+(iz) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x+1,y,z) + if (ix= 0.0 diff --git a/tests/newslv/spde.f90 b/tests/newslv/spde.f90 new file mode 100644 index 00000000..340ebe95 --- /dev/null +++ b/tests/newslv/spde.f90 @@ -0,0 +1,745 @@ +!!$ +!!$ +!!$ 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: ppde.f90 +! +! Program: ppde +! This sample program solves a linear system obtained by discretizing a +! PDE with Dirichlet BCs. +! +! +! The PDE is a general second order equation in 3d +! +! b1 dd(u) b2 dd(u) b3 dd(u) a1 d(u) a2 d(u) a3 d(u) +! - ------ - ------ - ------ - ----- - ------ - ------ + a4 u = 0 +! dxdx dydy dzdz dx dy dz +! +! with Dirichlet boundary conditions, on the unit cube 0<=x,y,z<=1. +! +! Example taken from: +! C.T.Kelley +! Iterative Methods for Linear and Nonlinear Equations +! SIAM 1995 +! +! In this sample program the index space of the discretized +! computational domain is first numbered sequentially in a standard way, +! then the corresponding vector is distributed according to a BLOCK +! data distribution. +! +! Boundary conditions are set in a very simple way, by adding +! equations of the form +! +! u(x,y) = exp(-x^2-y^2-z^2) +! +! Note that if a1=a2=a3=a4=0., the PDE is the well-known Laplace equation. +! +program spde + use psb_sparse_mod + use mld_prec_mod + use psb_krylov_mod + use psb_util_mod + use data_input + implicit none + + ! input parameters + character(len=20) :: kmethd, ptype + character(len=5) :: afmt + integer :: idim + + ! miscellaneous + real(psb_spk_), parameter :: one = 1.0 + real(psb_dpk_) :: t1, t2, tprec + + ! sparse matrix and preconditioner + type(psb_sspmat_type) :: a + type(mld_sprec_type) :: prec + ! descriptor + type(psb_desc_type) :: desc_a + ! dense matrices + real(psb_spk_), allocatable :: b(:), x(:) + ! blacs parameters + integer :: ictxt, iam, np + + ! solver parameters + integer :: iter, itmax,itrace, istopc, irst, nlv + integer(psb_long_int_k_) :: amatsize, precsize, descsize + real(psb_spk_) :: err, eps + + type precdata + character(len=20) :: descr ! verbose description of the prec + character(len=10) :: prec ! overall prectype + integer :: novr ! number of overlap layers + integer :: jsweeps ! Jacobi/smoother sweeps + character(len=16) :: restr ! restriction over application of as + character(len=16) :: prol ! prolongation over application of as + character(len=16) :: solve ! Solver type: ILU, SuperLU, UMFPACK. + integer :: fill1 ! Fill-in for factorization 1 + real(psb_spk_) :: thr1 ! Threshold for fact. 1 ILU(T) + character(len=16) :: smther ! Smoother + integer :: nlev ! Number of levels in multilevel prec. + character(len=16) :: aggrkind ! smoothed/raw aggregatin + character(len=16) :: aggr_alg ! local or global aggregation + character(len=16) :: mltype ! additive or multiplicative 2nd level prec + character(len=16) :: smthpos ! side: pre, post, both smoothing + character(len=16) :: cmat ! coarse mat + character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist + character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. + integer :: cfill ! Fill-in for factorization 1 + real(psb_spk_) :: cthres ! Threshold for fact. 1 ILU(T) + integer :: cjswp ! Jacobi sweeps + real(psb_spk_) :: athres ! smoother aggregation threshold + end type precdata + type(precdata) :: prectype + ! other variables + integer :: info + character(len=20) :: name,ch_err + + info=psb_success_ + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='pde90' + call psb_set_errverbosity(2) + + ! + ! get parameters + ! + call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + + ! + ! allocate and fill in the coefficient matrix, rhs and initial guess + ! + + call psb_barrier(ictxt) + t1 = psb_wtime() + call create_matrix(idim,a,b,x,desc_a,ictxt,afmt,info) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='create_matrix' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iam == psb_root_) write(*,'("Overall matrix creation time : ",es12.5)')t2 + if (iam == psb_root_) write(*,'(" ")') + ! + ! prepare the preconditioner. + ! + + if (psb_toupper(prectype%prec) == 'ML') then + nlv = prectype%nlev + call mld_precinit(prec,prectype%prec, info, nlev=nlv) + call mld_precset(prec,mld_smoother_type_, prectype%smther, info) + call mld_precset(prec,mld_smoother_sweeps_, prectype%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prectype%novr, info) + call mld_precset(prec,mld_sub_restr_, prectype%restr, info) + call mld_precset(prec,mld_sub_prol_, prectype%prol, info) + call mld_precset(prec,mld_sub_solve_, prectype%solve, info) + call mld_precset(prec,mld_sub_fillin_, prectype%fill1, info) + call mld_precset(prec,mld_sub_iluthrs_, prectype%thr1, info) + call mld_precset(prec,mld_aggr_kind_, prectype%aggrkind,info) + call mld_precset(prec,mld_aggr_alg_, prectype%aggr_alg,info) + call mld_precset(prec,mld_ml_type_, prectype%mltype, info) + call mld_precset(prec,mld_smoother_pos_, prectype%smthpos, info) + call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info) + call mld_precset(prec,mld_coarse_solve_, prectype%csolve, info) + call mld_precset(prec,mld_coarse_subsolve_, prectype%csbsolve,info) + call mld_precset(prec,mld_coarse_mat_, prectype%cmat, info) + call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) + call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) + call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + else + nlv = 1 + call mld_precinit(prec,prectype%prec, info, nlev=nlv) + call mld_precset(prec,mld_smoother_sweeps_, prectype%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prectype%novr, info) + call mld_precset(prec,mld_sub_restr_, prectype%restr, info) + call mld_precset(prec,mld_sub_prol_, prectype%prol, info) + call mld_precset(prec,mld_sub_solve_, prectype%solve, info) + call mld_precset(prec,mld_sub_fillin_, prectype%fill1, info) + call mld_precset(prec,mld_sub_iluthrs_, prectype%thr1, info) + end if + call psb_barrier(ictxt) + t1 = psb_wtime() + call mld_precbld(a,desc_a,prec,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_precbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + tprec = psb_wtime()-t1 + + call psb_amx(ictxt,tprec) + + if (iam == psb_root_) write(*,'("Preconditioner time : ",es12.5)')tprec + if (iam == psb_root_) call mld_precdescr(prec,info) + if (iam == psb_root_) write(*,'(" ")') + + ! + ! iterative method parameters + ! + if(iam == psb_root_) write(*,'("Calling iterative method ",a)')kmethd + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_krylov(kmethd,a,prec,b,x,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='solver routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + call psb_amx(ictxt,t2) + + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + precsize = mld_sizeof(prec) + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam == psb_root_) then + write(*,'(" ")') + write(*,'("Time to solve matrix : ",es12.5)')t2 + write(*,'("Time per iteration : ",es12.5)')t2/iter + write(*,'("Number of iterations : ",i0)')iter + write(*,'("Convergence indicator on exit : ",es12.5)')err + write(*,'("Info on exit : ",i0)')info + write(*,'("Total memory occupation for A: ",i12)')amatsize + write(*,'("Total memory occupation for DESC_A: ",i12)')descsize + write(*,'("Total memory occupation for PREC: ",i12)')precsize + end if + + ! + ! cleanup storage and exit + ! + call psb_gefree(b,desc_a,info) + call psb_gefree(x,desc_a,info) + call psb_spfree(a,desc_a,info) + call mld_precfree(prec,info) + call psb_cdfree(desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + +9999 continue + if(info /= psb_success_) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + integer :: ictxt + type(precdata) :: prectype + character(len=*) :: kmethd, afmt + integer :: idim, istopc,itmax,itrace,irst + integer :: np, iam, info + real(psb_spk_) :: eps + character(len=20) :: buffer + + call psb_info(ictxt, iam, np) + + if (iam == psb_root_) then + call read_data(kmethd,5) + call read_data(afmt,5) + call read_data(idim,5) + call read_data(istopc,5) + call read_data(itmax,5) + call read_data(itrace,5) + call read_data(irst,5) + call read_data(eps,5) + call read_data(prectype%descr,5) ! verbose description of the prec + call read_data(prectype%prec,5) ! overall prectype + call read_data(prectype%novr,5) ! number of overlap layers + call read_data(prectype%restr,5) ! restriction over application of as + call read_data(prectype%prol,5) ! prolongation over application of as + call read_data(prectype%solve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%fill1,5) ! Fill-in for factorization 1 + call read_data(prectype%thr1,5) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%jsweeps,5) ! Jacobi sweeps for PJAC + if (psb_toupper(prectype%prec) == 'ML') then + call read_data(prectype%smther,5) ! Smoother type. + call read_data(prectype%nlev,5) ! Number of levels in multilevel prec. + call read_data(prectype%aggrkind,5) ! smoothed/raw aggregatin + call read_data(prectype%aggr_alg,5) ! local or global aggregation + call read_data(prectype%mltype,5) ! additive or multiplicative 2nd level prec + call read_data(prectype%smthpos,5) ! side: pre, post, both smoothing + call read_data(prectype%cmat,5) ! coarse mat + call read_data(prectype%csolve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%csbsolve,5) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%cfill,5) ! Fill-in for factorization 1 + call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%cjswp,5) ! Jacobi sweeps + call read_data(prectype%athres,5) ! smoother aggr thresh + end if + end if + + ! broadcast parameters to all processors + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,afmt) + call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,istopc) + call psb_bcast(ictxt,itmax) + call psb_bcast(ictxt,itrace) + call psb_bcast(ictxt,irst) + call psb_bcast(ictxt,eps) + + + call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec + call psb_bcast(ictxt,prectype%prec) ! overall prectype + call psb_bcast(ictxt,prectype%novr) ! number of overlap layers + call psb_bcast(ictxt,prectype%restr) ! restriction over application of as + call psb_bcast(ictxt,prectype%prol) ! prolongation over application of as + call psb_bcast(ictxt,prectype%solve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%fill1) ! Fill-in for factorization 1 + call psb_bcast(ictxt,prectype%thr1) ! Threshold for fact. 1 ILU(T) + call psb_bcast(ictxt,prectype%jsweeps) ! Jacobi sweeps + if (psb_toupper(prectype%prec) == 'ML') then + call psb_bcast(ictxt,prectype%smther) ! Smoother type. + call psb_bcast(ictxt,prectype%nlev) ! Number of levels in multilevel prec. + call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/raw aggregatin + call psb_bcast(ictxt,prectype%aggr_alg) ! local or global aggregation + call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec + call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing + call psb_bcast(ictxt,prectype%cmat) ! coarse mat + call psb_bcast(ictxt,prectype%csolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%csbsolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%cfill) ! Fill-in for factorization 1 + call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) + call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps + call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + end if + + if (iam == psb_root_) then + write(*,'("Solving matrix : ell1")') + write(*,'("Grid dimensions : ",i4,"x",i4,"x",i4)')idim,idim,idim + write(*,'("Number of processors : ",i0)') np + write(*,'("Data distribution : BLOCK")') + write(*,'("Preconditioner : ",a)') prectype%descr + write(*,'("Iterative method : ",a)') kmethd + write(*,'(" ")') + endif + + return + + end subroutine get_parms + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer :: iout + write(iout,*)'incorrect parameter(s) found' + write(iout,*)' usage: pde90 methd prec dim & + &[istop itmax itrace]' + write(iout,*)' where:' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' prec : bjac diag none' + write(iout,*)' dim number of points along each axis' + write(iout,*)' the size of the resulting linear ' + write(iout,*)' system is dim**3' + write(iout,*)' istop stopping criterion 1, 2 ' + write(iout,*)' itmax maximum number of iterations [500] ' + write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' >= 1 do tracing every itrace' + write(iout,*)' iterations ' + end subroutine pr_usage + + ! + ! subroutine to allocate and fill in the coefficient matrix and + ! the rhs. + ! + subroutine create_matrix(idim,a,b,xv,desc_a,ictxt,afmt,info) + ! + ! discretize the partial diferential equation + ! + ! b1 dd(u) b2 dd(u) b3 dd(u) a1 d(u) a2 d(u) a3 d(u) + ! - ------ - ------ - ------ - ----- - ------ - ------ + a4 u + ! dxdx dydy dzdz dx dy dz + ! + ! with Dirichlet boundary conditions, on the unit cube 0<=x,y,z<=1. + ! + ! Boundary conditions are set in a very simple way, by adding + ! equations of the form + ! + ! u(x,y) = exp(-x^2-y^2-z^2) + ! + ! Note that if a1=a2=a3=a4=0., the PDE is the well-known Laplace equation. + ! + use psb_sparse_mod + implicit none + integer :: idim + integer, parameter :: nb=20 + real(psb_spk_), allocatable :: b(:),xv(:) + type(psb_desc_type) :: desc_a + integer :: ictxt, info + character :: afmt*5 + type(psb_sspmat_type) :: a + real(psb_spk_) :: zt(nb),x,y,z + integer :: m,n,nnz,glob_row,nlr,i,ii,ib,k + integer :: ix,iy,iz,ia,indx_owner + integer :: np, iam, nr, nt + integer :: element + integer, allocatable :: irow(:),icol(:),myidx(:) + real(psb_spk_), allocatable :: val(:) + ! deltah dimension of each grid cell + ! deltat discretization time + real(psb_spk_) :: deltah + real(psb_spk_),parameter :: rhs=0.0,one=1.0,zero=0.0 + real(psb_dpk_) :: t0, t1, t2, t3, tasb, talc, ttot, tgen + real(psb_spk_) :: a1, a2, a3, a4, b1, b2, b3 + external :: a1, a2, a3, a4, b1, b2, b3 + integer :: err_act + + character(len=20) :: name, ch_err + + info = psb_success_ + name = 'create_matrix' + call psb_erractionsave(err_act) + + call psb_info(ictxt, iam, np) + + deltah = 1.0/(idim-1) + + ! initialize array descriptor and sparse matrix storage. provide an + ! estimate of the number of non zeroes + + m = idim*idim*idim + n = m + nnz = ((n*9)/(np)) + if(iam == psb_root_) write(0,'("Generating Matrix (size=",i0,")...")')n + + ! + ! Using a simple BLOCK distribution. + ! + nt = (m+np-1)/np + nr = max(0,min(nt,m-(iam*nt))) + + nt = nr + call psb_sum(ictxt,nt) + if (nt /= m) write(0,*) iam, 'Initialization error ',nr,nt,m + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdall(ictxt,desc_a,info,nl=nr) + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) + ! define rhs from boundary conditions; also build initial guess + if (info == psb_success_) call psb_geall(b,desc_a,info) + if (info == psb_success_) call psb_geall(xv,desc_a,info) + nlr = psb_cd_get_local_rows(desc_a) + call psb_barrier(ictxt) + talc = psb_wtime()-t0 + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! we build an auxiliary matrix consisting of one row at a + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),myidx(nlr),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1,nlr + myidx(i) = i + end do + + + call psb_loc_to_glob(myidx,desc_a,info) + + ! loop over rows belonging to current process in a block + ! distribution. + + call psb_barrier(ictxt) + t1 = psb_wtime() + do ii=1, nlr,nb + ib = min(nb,nlr-ii+1) + element = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + if (mod(glob_row,(idim*idim)) == 0) then + ix = glob_row/(idim*idim) + else + ix = glob_row/(idim*idim)+1 + endif + if (mod((glob_row-(ix-1)*idim*idim),idim) == 0) then + iy = (glob_row-(ix-1)*idim*idim)/idim + else + iy = (glob_row-(ix-1)*idim*idim)/idim+1 + endif + iz = glob_row-(ix-1)*idim*idim-(iy-1)*idim + ! x, y, x coordinates + x = ix*deltah + y = iy*deltah + z = iz*deltah + + ! check on boundary points + zt(k) = 0.d0 + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + if (ix == 1) then + val(element)=-b1(x,y,z)-a1(x,y,z) + val(element) = val(element)/(deltah*& + & deltah) + zt(k) = exp(-y**2-z**2)*(-val(element)) + else + val(element)=-b1(x,y,z)-a1(x,y,z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element) = (ix-2)*idim*idim+(iy-1)*idim+(iz) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x,y-1,z) + if (iy == 1) then + val(element)=-b2(x,y,z)-a2(x,y,z) + val(element) = val(element)/(deltah*& + & deltah) + zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) + else + val(element)=-b2(x,y,z)-a2(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy-2)*idim+(iz) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x,y,z-1) + if (iz == 1) then + val(element)=-b3(x,y,z)-a3(x,y,z) + val(element) = val(element)/(deltah*deltah) + zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) + else + val(element)=-b3(x,y,z)-a3(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy-1)*idim+(iz-1) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x,y,z) + val(element)=2*b1(x,y,z) + 2*b2(x,y,z)& + & + 2*b3(x,y,z) + a1(x,y,z)& + & + a2(x,y,z) + a3(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy-1)*idim+(iz) + irow(element) = glob_row + element = element+1 + ! term depending on (x,y,z+1) + if (iz == idim) then + val(element)=-b1(x,y,z) + val(element) = val(element)/(deltah*deltah) + zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) + else + val(element)=-b1(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy-1)*idim+(iz+1) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x,y+1,z) + if (iy == idim) then + val(element)=-b2(x,y,z) + val(element) = val(element)/(deltah*deltah) + zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) + else + val(element)=-b2(x,y,z) + val(element) = val(element)/(deltah*deltah) + icol(element) = (ix-1)*idim*idim+(iy)*idim+(iz) + irow(element) = glob_row + element = element+1 + endif + ! term depending on (x+1,y,z) + if (ix= 0.0