diff --git a/Changelog b/Changelog index e2c1d9bb..ade0be90 100644 --- a/Changelog +++ b/Changelog @@ -1,5 +1,8 @@ Changelog. A lot less detailed than usual, at least for past history. +2016/05/18: Reworked internals of PRECSET. Defined Forward-Backward + Gauss-Seidel solver. Now available separate PRE and POST smoother + objects. 2016/03/30: MUMPS interface. 2016/02/28: Hybrid Gauss-Seidel method. 2016/02/03: unify integer argument checks. diff --git a/mlprec/impl/level/Makefile b/mlprec/impl/level/Makefile index bd50f2a0..7485c10b 100644 --- a/mlprec/impl/level/Makefile +++ b/mlprec/impl/level/Makefile @@ -19,6 +19,8 @@ mld_c_base_onelev_free.o \ mld_c_base_onelev_setc.o \ mld_c_base_onelev_seti.o \ mld_c_base_onelev_setr.o \ +mld_c_base_onelev_setsm.o \ +mld_c_base_onelev_setsv.o \ mld_d_base_onelev_check.o \ mld_d_base_onelev_cnv.o \ mld_d_base_onelev_csetc.o \ @@ -30,6 +32,8 @@ mld_d_base_onelev_free.o \ mld_d_base_onelev_setc.o \ mld_d_base_onelev_seti.o \ mld_d_base_onelev_setr.o \ +mld_d_base_onelev_setsm.o \ +mld_d_base_onelev_setsv.o \ mld_s_base_onelev_check.o \ mld_s_base_onelev_cnv.o \ mld_s_base_onelev_csetc.o \ @@ -41,6 +45,8 @@ mld_s_base_onelev_free.o \ mld_s_base_onelev_setc.o \ mld_s_base_onelev_seti.o \ mld_s_base_onelev_setr.o \ +mld_s_base_onelev_setsm.o \ +mld_s_base_onelev_setsv.o \ mld_z_base_onelev_check.o \ mld_z_base_onelev_cnv.o \ mld_z_base_onelev_csetc.o \ @@ -51,7 +57,9 @@ mld_z_base_onelev_dump.o \ mld_z_base_onelev_free.o \ mld_z_base_onelev_setc.o \ mld_z_base_onelev_seti.o \ -mld_z_base_onelev_setr.o +mld_z_base_onelev_setr.o \ +mld_z_base_onelev_setsm.o \ +mld_z_base_onelev_setsv.o LIBNAME=libmld_prec.a diff --git a/mlprec/impl/level/mld_c_base_onelev_csetc.f90 b/mlprec/impl/level/mld_c_base_onelev_csetc.f90 index 20d2c821..4d9f0d18 100644 --- a/mlprec/impl/level/mld_c_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_csetc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_csetc(lv,what,val,info) +subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_csetc @@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info) character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -58,11 +60,35 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if diff --git a/mlprec/impl/level/mld_c_base_onelev_cseti.F90 b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 new file mode 100644 index 00000000..6399420e --- /dev/null +++ b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 @@ -0,0 +1,251 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos) + + use psb_base_mod + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_cseti + use mld_c_jac_smoother + use mld_c_as_smoother + use mld_c_diag_solver + use mld_c_ilu_solver + use mld_c_id_solver + use mld_c_gs_solver +#if defined(HAVE_UMF_) + use mld_c_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_c_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_c_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_c_mumps_solver +#endif + + Implicit None + + ! Arguments + class(mld_c_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='c_base_onelev_cseti' + type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold + type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold + type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold + type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold + type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold + type(mld_c_id_solver_type) :: mld_c_id_solver_mold + type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold + type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_c_umf_solver_type) :: mld_c_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_c_sludist_solver_type) :: mld_c_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_c_mumps_solver_type) :: mld_c_mumps_solver_mold +#endif + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (mld_noprec_) + call lv%set(mld_c_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_c_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case('SUB_SOLVE') + select case (val) + case (mld_f_none_) + call lv%set(mld_c_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_c_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_c_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_c_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_c_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_c_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_c_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + + case ('SMOOTHER_SWEEPS') + lv%parms%sweeps = val + lv%parms%sweeps_pre = val + lv%parms%sweeps_post = val + + case ('SMOOTHER_SWEEPS_PRE') + lv%parms%sweeps_pre = val + + case ('SMOOTHER_SWEEPS_POST') + lv%parms%sweeps_post = val + + case ('ML_TYPE') + lv%parms%ml_type = val + + case ('AGGR_ALG') + lv%parms%aggr_alg = val + + case ('AGGR_ORD') + lv%parms%aggr_ord = val + + case ('AGGR_KIND') + lv%parms%aggr_kind = val + + case ('COARSE_MAT') + lv%parms%coarse_mat = val + + case ('SMOOTHER_POS') + lv%parms%smoother_pos = val + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= val + + case ('AGGR_EIG') + lv%parms%aggr_eig = val + + case ('AGGR_FILTER') + lv%parms%aggr_filter = val + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = val + + case default + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + + end select + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_c_base_onelev_cseti diff --git a/mlprec/impl/level/mld_c_base_onelev_csetr.f90 b/mlprec/impl/level/mld_c_base_onelev_csetr.f90 index e7dda2f5..562fab6b 100644 --- a/mlprec/impl/level/mld_c_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_csetr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_csetr(lv,what,val,info) +subroutine mld_c_base_onelev_csetr(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_csetr @@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info) character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_csetr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_c_base_onelev_setc.f90 b/mlprec/impl/level/mld_c_base_onelev_setc.f90 index 4b60b17c..909a3d1b 100644 --- a/mlprec/impl/level/mld_c_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_setc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_setc(lv,what,val,info) +subroutine mld_c_base_onelev_setc(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setc @@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info) integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_setc' integer(psb_ipk_) :: ival @@ -58,14 +60,36 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end if - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_c_base_onelev_seti.F90 b/mlprec/impl/level/mld_c_base_onelev_seti.F90 new file mode 100644 index 00000000..46a2ee2b --- /dev/null +++ b/mlprec/impl/level/mld_c_base_onelev_seti.F90 @@ -0,0 +1,251 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_base_onelev_seti(lv,what,val,info,pos) + + use psb_base_mod + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_seti + use mld_c_jac_smoother + use mld_c_as_smoother + use mld_c_diag_solver + use mld_c_ilu_solver + use mld_c_id_solver + use mld_c_gs_solver +#if defined(HAVE_UMF_) + use mld_c_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_c_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_c_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_c_mumps_solver +#endif + + Implicit None + + ! Arguments + class(mld_c_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='c_base_onelev_seti' + type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold + type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold + type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold + type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold + type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold + type(mld_c_id_solver_type) :: mld_c_id_solver_mold + type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold + type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_c_umf_solver_type) :: mld_c_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_c_sludist_solver_type) :: mld_c_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_c_mumps_solver_type) :: mld_c_mumps_solver_mold +#endif + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case (what) + + case (mld_smoother_type_) + select case (val) + case (mld_noprec_) + call lv%set(mld_c_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_c_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case(mld_sub_solve_) + select case (val) + case (mld_f_none_) + call lv%set(mld_c_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_c_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_c_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_c_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_c_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_c_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_c_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + case (mld_smoother_sweeps_) + lv%parms%sweeps = val + lv%parms%sweeps_pre = val + lv%parms%sweeps_post = val + + case (mld_smoother_sweeps_pre_) + lv%parms%sweeps_pre = val + + case (mld_smoother_sweeps_post_) + 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_ord_) + lv%parms%aggr_ord = 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 + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + + end select + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_c_base_onelev_seti diff --git a/mlprec/impl/level/mld_c_base_onelev_setr.f90 b/mlprec/impl/level/mld_c_base_onelev_setr.f90 index c371136c..4187e049 100644 --- a/mlprec/impl/level/mld_c_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_setr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_setr(lv,what,val,info) +subroutine mld_c_base_onelev_setr(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setr @@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_setr(lv,what,val,info) integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_setr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_c_base_onelev_setr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_c_base_onelev_setsm.F90 b/mlprec/impl/level/mld_c_base_onelev_setsm.F90 new file mode 100644 index 00000000..f0bf8b39 --- /dev/null +++ b/mlprec/impl/level/mld_c_base_onelev_setsm.F90 @@ -0,0 +1,107 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_base_onelev_setsm(lev,val,info,pos) + + use psb_base_mod + use mld_c_prec_mod, mld_protect_name => mld_c_base_onelev_setsm + + implicit none + + ! Arguments + class(mld_c_onelev_type), target, intent(inout) :: lev + class(mld_c_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (.not.same_type_as(lev%sm,val)) then + call lev%sm%free(info) + deallocate(lev%sm, stat=info) + end if + endif + if (.not.allocated(lev%sm)) then +#ifdef HAVE_MOLD + allocate(lev%sm,mold=val) +#else + allocate(lev%sm,source=val) +#endif + end if + call lev%sm%default() + lev%sm2 => lev%sm + case(mld_post_smooth_) + if (allocated(lev%sm2a)) then + if (.not.same_type_as(lev%sm2a,val)) then + call lev%sm2a%free(info) + deallocate(lev%sm2a, stat=info) + endif + end if + if (.not.allocated(lev%sm2a)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a,mold=val) +#else + allocate(lev%sm2a,source=val) +#endif + end if + call lev%sm2a%default() + lev%sm2 => lev%sm2a + end select + +end subroutine mld_c_base_onelev_setsm + diff --git a/mlprec/impl/level/mld_c_base_onelev_setsv.F90 b/mlprec/impl/level/mld_c_base_onelev_setsv.F90 new file mode 100644 index 00000000..f605baa4 --- /dev/null +++ b/mlprec/impl/level/mld_c_base_onelev_setsv.F90 @@ -0,0 +1,144 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_base_onelev_setsv(lev,val,info,pos) + + use psb_base_mod + use mld_c_prec_mod, mld_protect_name => mld_c_base_onelev_setsv + + implicit none + + ! Arguments + class(mld_c_onelev_type), target, intent(inout) :: lev + class(mld_c_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (allocated(lev%sm%sv)) then + if (.not.same_type_as(lev%sm%sv,val)) then + call lev%sm%sv%free(info) + deallocate(lev%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lev%sm%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm%sv,mold=val,stat=info) +#else + allocate(lev%sm%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + case(mld_post_smooth_) + + if (allocated(lev%sm2a)) then + if (allocated(lev%sm2a%sv)) then + if (.not.same_type_as(lev%sm2a%sv,val)) then + call lev%sm2a%sv%free(info) + deallocate(lev%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lev%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a%sv,mold=val,stat=info) +#else + allocate(lev%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm2a%sv%default() + + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end select + +end subroutine mld_c_base_onelev_setsv + diff --git a/mlprec/impl/level/mld_d_base_onelev_csetc.f90 b/mlprec/impl/level/mld_d_base_onelev_csetc.f90 index c645120c..46c47d6a 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_csetc(lv,what,val,info) +subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_csetc @@ -48,7 +48,9 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info) character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -58,11 +60,35 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 new file mode 100644 index 00000000..987886d4 --- /dev/null +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 @@ -0,0 +1,251 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) + + use psb_base_mod + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_cseti + 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 + use mld_d_gs_solver +#if defined(HAVE_UMF_) + use mld_d_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_d_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_d_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_d_mumps_solver +#endif + + Implicit None + + ! Arguments + class(mld_d_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='d_base_onelev_cseti' + type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold + type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold + type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold + type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold + type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold + type(mld_d_id_solver_type) :: mld_d_id_solver_mold + type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold + type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_d_sludist_solver_type) :: mld_d_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_d_slu_solver_type) :: mld_d_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_d_mumps_solver_type) :: mld_d_mumps_solver_mold +#endif + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (mld_noprec_) + call lv%set(mld_d_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_d_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case('SUB_SOLVE') + select case (val) + case (mld_f_none_) + call lv%set(mld_d_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_d_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_d_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_d_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_d_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_d_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_d_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + + case ('SMOOTHER_SWEEPS') + lv%parms%sweeps = val + lv%parms%sweeps_pre = val + lv%parms%sweeps_post = val + + case ('SMOOTHER_SWEEPS_PRE') + lv%parms%sweeps_pre = val + + case ('SMOOTHER_SWEEPS_POST') + lv%parms%sweeps_post = val + + case ('ML_TYPE') + lv%parms%ml_type = val + + case ('AGGR_ALG') + lv%parms%aggr_alg = val + + case ('AGGR_ORD') + lv%parms%aggr_ord = val + + case ('AGGR_KIND') + lv%parms%aggr_kind = val + + case ('COARSE_MAT') + lv%parms%coarse_mat = val + + case ('SMOOTHER_POS') + lv%parms%smoother_pos = val + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= val + + case ('AGGR_EIG') + lv%parms%aggr_eig = val + + case ('AGGR_FILTER') + lv%parms%aggr_filter = val + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = val + + case default + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + + end select + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_d_base_onelev_cseti diff --git a/mlprec/impl/level/mld_d_base_onelev_csetr.f90 b/mlprec/impl/level/mld_d_base_onelev_csetr.f90 index bb35507f..04961850 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_csetr(lv,what,val,info) +subroutine mld_d_base_onelev_csetr(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_csetr @@ -48,7 +48,9 @@ subroutine mld_d_base_onelev_csetr(lv,what,val,info) character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_csetr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_d_base_onelev_csetr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_d_base_onelev_setc.f90 b/mlprec/impl/level/mld_d_base_onelev_setc.f90 index 417dcf78..6474489b 100644 --- a/mlprec/impl/level/mld_d_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_setc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_setc(lv,what,val,info) +subroutine mld_d_base_onelev_setc(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_setc @@ -48,7 +48,9 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info) integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_setc' integer(psb_ipk_) :: ival @@ -58,14 +60,36 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end if - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_d_base_onelev_seti.F90 b/mlprec/impl/level/mld_d_base_onelev_seti.F90 new file mode 100644 index 00000000..63aab65f --- /dev/null +++ b/mlprec/impl/level/mld_d_base_onelev_seti.F90 @@ -0,0 +1,251 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) + + use psb_base_mod + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_seti + 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 + use mld_d_gs_solver +#if defined(HAVE_UMF_) + use mld_d_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_d_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_d_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_d_mumps_solver +#endif + + Implicit None + + ! Arguments + class(mld_d_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='d_base_onelev_seti' + type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold + type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold + type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold + type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold + type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold + type(mld_d_id_solver_type) :: mld_d_id_solver_mold + type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold + type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_d_sludist_solver_type) :: mld_d_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_d_slu_solver_type) :: mld_d_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_d_mumps_solver_type) :: mld_d_mumps_solver_mold +#endif + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case (what) + + case (mld_smoother_type_) + select case (val) + case (mld_noprec_) + call lv%set(mld_d_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_d_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case(mld_sub_solve_) + select case (val) + case (mld_f_none_) + call lv%set(mld_d_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_d_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_d_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_d_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_d_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_d_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_d_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + case (mld_smoother_sweeps_) + lv%parms%sweeps = val + lv%parms%sweeps_pre = val + lv%parms%sweeps_post = val + + case (mld_smoother_sweeps_pre_) + lv%parms%sweeps_pre = val + + case (mld_smoother_sweeps_post_) + 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_ord_) + lv%parms%aggr_ord = 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 + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + + end select + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_d_base_onelev_seti diff --git a/mlprec/impl/level/mld_d_base_onelev_setr.f90 b/mlprec/impl/level/mld_d_base_onelev_setr.f90 index 8695c9a5..788e7319 100644 --- a/mlprec/impl/level/mld_d_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_setr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_setr(lv,what,val,info) +subroutine mld_d_base_onelev_setr(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_setr @@ -48,7 +48,9 @@ subroutine mld_d_base_onelev_setr(lv,what,val,info) integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_setr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_d_base_onelev_setr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_d_base_onelev_setsm.F90 b/mlprec/impl/level/mld_d_base_onelev_setsm.F90 new file mode 100644 index 00000000..c0770327 --- /dev/null +++ b/mlprec/impl/level/mld_d_base_onelev_setsm.F90 @@ -0,0 +1,107 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_base_onelev_setsm(lev,val,info,pos) + + use psb_base_mod + use mld_d_prec_mod, mld_protect_name => mld_d_base_onelev_setsm + + implicit none + + ! Arguments + class(mld_d_onelev_type), target, intent(inout) :: lev + class(mld_d_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (.not.same_type_as(lev%sm,val)) then + call lev%sm%free(info) + deallocate(lev%sm, stat=info) + end if + endif + if (.not.allocated(lev%sm)) then +#ifdef HAVE_MOLD + allocate(lev%sm,mold=val) +#else + allocate(lev%sm,source=val) +#endif + end if + call lev%sm%default() + lev%sm2 => lev%sm + case(mld_post_smooth_) + if (allocated(lev%sm2a)) then + if (.not.same_type_as(lev%sm2a,val)) then + call lev%sm2a%free(info) + deallocate(lev%sm2a, stat=info) + endif + end if + if (.not.allocated(lev%sm2a)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a,mold=val) +#else + allocate(lev%sm2a,source=val) +#endif + end if + call lev%sm2a%default() + lev%sm2 => lev%sm2a + end select + +end subroutine mld_d_base_onelev_setsm + diff --git a/mlprec/impl/level/mld_d_base_onelev_setsv.F90 b/mlprec/impl/level/mld_d_base_onelev_setsv.F90 new file mode 100644 index 00000000..aefdd015 --- /dev/null +++ b/mlprec/impl/level/mld_d_base_onelev_setsv.F90 @@ -0,0 +1,144 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_base_onelev_setsv(lev,val,info,pos) + + use psb_base_mod + use mld_d_prec_mod, mld_protect_name => mld_d_base_onelev_setsv + + implicit none + + ! Arguments + class(mld_d_onelev_type), target, intent(inout) :: lev + class(mld_d_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (allocated(lev%sm%sv)) then + if (.not.same_type_as(lev%sm%sv,val)) then + call lev%sm%sv%free(info) + deallocate(lev%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lev%sm%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm%sv,mold=val,stat=info) +#else + allocate(lev%sm%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + case(mld_post_smooth_) + + if (allocated(lev%sm2a)) then + if (allocated(lev%sm2a%sv)) then + if (.not.same_type_as(lev%sm2a%sv,val)) then + call lev%sm2a%sv%free(info) + deallocate(lev%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lev%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a%sv,mold=val,stat=info) +#else + allocate(lev%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm2a%sv%default() + + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end select + +end subroutine mld_d_base_onelev_setsv + diff --git a/mlprec/impl/level/mld_s_base_onelev_csetc.f90 b/mlprec/impl/level/mld_s_base_onelev_csetc.f90 index c60ca08f..2cf0db01 100644 --- a/mlprec/impl/level/mld_s_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_csetc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_csetc(lv,what,val,info) +subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_csetc @@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info) character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -58,11 +60,35 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if diff --git a/mlprec/impl/level/mld_s_base_onelev_cseti.F90 b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 new file mode 100644 index 00000000..16e4e00d --- /dev/null +++ b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 @@ -0,0 +1,251 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos) + + use psb_base_mod + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_cseti + 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 + use mld_s_gs_solver +#if defined(HAVE_UMF_) + use mld_s_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_s_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_s_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_s_mumps_solver +#endif + + Implicit None + + ! Arguments + class(mld_s_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='s_base_onelev_cseti' + type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold + type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold + type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold + type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold + type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold + type(mld_s_id_solver_type) :: mld_s_id_solver_mold + type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold + type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_s_umf_solver_type) :: mld_s_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_s_sludist_solver_type) :: mld_s_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_s_mumps_solver_type) :: mld_s_mumps_solver_mold +#endif + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (mld_noprec_) + call lv%set(mld_s_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_s_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case('SUB_SOLVE') + select case (val) + case (mld_f_none_) + call lv%set(mld_s_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_s_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_s_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_s_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_s_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_s_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_s_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + + case ('SMOOTHER_SWEEPS') + lv%parms%sweeps = val + lv%parms%sweeps_pre = val + lv%parms%sweeps_post = val + + case ('SMOOTHER_SWEEPS_PRE') + lv%parms%sweeps_pre = val + + case ('SMOOTHER_SWEEPS_POST') + lv%parms%sweeps_post = val + + case ('ML_TYPE') + lv%parms%ml_type = val + + case ('AGGR_ALG') + lv%parms%aggr_alg = val + + case ('AGGR_ORD') + lv%parms%aggr_ord = val + + case ('AGGR_KIND') + lv%parms%aggr_kind = val + + case ('COARSE_MAT') + lv%parms%coarse_mat = val + + case ('SMOOTHER_POS') + lv%parms%smoother_pos = val + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= val + + case ('AGGR_EIG') + lv%parms%aggr_eig = val + + case ('AGGR_FILTER') + lv%parms%aggr_filter = val + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = val + + case default + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + + end select + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_s_base_onelev_cseti diff --git a/mlprec/impl/level/mld_s_base_onelev_csetr.f90 b/mlprec/impl/level/mld_s_base_onelev_csetr.f90 index 77d52d40..1b910a65 100644 --- a/mlprec/impl/level/mld_s_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_csetr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_csetr(lv,what,val,info) +subroutine mld_s_base_onelev_csetr(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_csetr @@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info) character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_csetr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_s_base_onelev_setc.f90 b/mlprec/impl/level/mld_s_base_onelev_setc.f90 index 9f3aa570..03a6086c 100644 --- a/mlprec/impl/level/mld_s_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_setc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_setc(lv,what,val,info) +subroutine mld_s_base_onelev_setc(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setc @@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info) integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_setc' integer(psb_ipk_) :: ival @@ -58,14 +60,36 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end if - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_s_base_onelev_seti.F90 b/mlprec/impl/level/mld_s_base_onelev_seti.F90 new file mode 100644 index 00000000..49774d04 --- /dev/null +++ b/mlprec/impl/level/mld_s_base_onelev_seti.F90 @@ -0,0 +1,251 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_base_onelev_seti(lv,what,val,info,pos) + + use psb_base_mod + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_seti + 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 + use mld_s_gs_solver +#if defined(HAVE_UMF_) + use mld_s_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_s_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_s_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_s_mumps_solver +#endif + + Implicit None + + ! Arguments + class(mld_s_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='s_base_onelev_seti' + type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold + type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold + type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold + type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold + type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold + type(mld_s_id_solver_type) :: mld_s_id_solver_mold + type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold + type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_s_umf_solver_type) :: mld_s_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_s_sludist_solver_type) :: mld_s_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_s_mumps_solver_type) :: mld_s_mumps_solver_mold +#endif + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case (what) + + case (mld_smoother_type_) + select case (val) + case (mld_noprec_) + call lv%set(mld_s_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_s_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case(mld_sub_solve_) + select case (val) + case (mld_f_none_) + call lv%set(mld_s_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_s_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_s_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_s_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_s_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_s_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_s_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + case (mld_smoother_sweeps_) + lv%parms%sweeps = val + lv%parms%sweeps_pre = val + lv%parms%sweeps_post = val + + case (mld_smoother_sweeps_pre_) + lv%parms%sweeps_pre = val + + case (mld_smoother_sweeps_post_) + 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_ord_) + lv%parms%aggr_ord = 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 + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + + end select + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_s_base_onelev_seti diff --git a/mlprec/impl/level/mld_s_base_onelev_setr.f90 b/mlprec/impl/level/mld_s_base_onelev_setr.f90 index 239c1454..b811d2b6 100644 --- a/mlprec/impl/level/mld_s_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_setr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_setr(lv,what,val,info) +subroutine mld_s_base_onelev_setr(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setr @@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_setr(lv,what,val,info) integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_setr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_s_base_onelev_setr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_s_base_onelev_setsm.F90 b/mlprec/impl/level/mld_s_base_onelev_setsm.F90 new file mode 100644 index 00000000..ae42b099 --- /dev/null +++ b/mlprec/impl/level/mld_s_base_onelev_setsm.F90 @@ -0,0 +1,107 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_base_onelev_setsm(lev,val,info,pos) + + use psb_base_mod + use mld_s_prec_mod, mld_protect_name => mld_s_base_onelev_setsm + + implicit none + + ! Arguments + class(mld_s_onelev_type), target, intent(inout) :: lev + class(mld_s_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (.not.same_type_as(lev%sm,val)) then + call lev%sm%free(info) + deallocate(lev%sm, stat=info) + end if + endif + if (.not.allocated(lev%sm)) then +#ifdef HAVE_MOLD + allocate(lev%sm,mold=val) +#else + allocate(lev%sm,source=val) +#endif + end if + call lev%sm%default() + lev%sm2 => lev%sm + case(mld_post_smooth_) + if (allocated(lev%sm2a)) then + if (.not.same_type_as(lev%sm2a,val)) then + call lev%sm2a%free(info) + deallocate(lev%sm2a, stat=info) + endif + end if + if (.not.allocated(lev%sm2a)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a,mold=val) +#else + allocate(lev%sm2a,source=val) +#endif + end if + call lev%sm2a%default() + lev%sm2 => lev%sm2a + end select + +end subroutine mld_s_base_onelev_setsm + diff --git a/mlprec/impl/level/mld_s_base_onelev_setsv.F90 b/mlprec/impl/level/mld_s_base_onelev_setsv.F90 new file mode 100644 index 00000000..2bcac850 --- /dev/null +++ b/mlprec/impl/level/mld_s_base_onelev_setsv.F90 @@ -0,0 +1,144 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_base_onelev_setsv(lev,val,info,pos) + + use psb_base_mod + use mld_s_prec_mod, mld_protect_name => mld_s_base_onelev_setsv + + implicit none + + ! Arguments + class(mld_s_onelev_type), target, intent(inout) :: lev + class(mld_s_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (allocated(lev%sm%sv)) then + if (.not.same_type_as(lev%sm%sv,val)) then + call lev%sm%sv%free(info) + deallocate(lev%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lev%sm%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm%sv,mold=val,stat=info) +#else + allocate(lev%sm%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + case(mld_post_smooth_) + + if (allocated(lev%sm2a)) then + if (allocated(lev%sm2a%sv)) then + if (.not.same_type_as(lev%sm2a%sv,val)) then + call lev%sm2a%sv%free(info) + deallocate(lev%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lev%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a%sv,mold=val,stat=info) +#else + allocate(lev%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm2a%sv%default() + + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end select + +end subroutine mld_s_base_onelev_setsv + diff --git a/mlprec/impl/level/mld_z_base_onelev_csetc.f90 b/mlprec/impl/level/mld_z_base_onelev_csetc.f90 index 8bc3f390..0ea8ed13 100644 --- a/mlprec/impl/level/mld_z_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_csetc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_csetc(lv,what,val,info) +subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_csetc @@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info) character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -58,11 +60,35 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if diff --git a/mlprec/impl/level/mld_z_base_onelev_cseti.F90 b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 new file mode 100644 index 00000000..2ad9db47 --- /dev/null +++ b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 @@ -0,0 +1,251 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos) + + use psb_base_mod + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_cseti + use mld_z_jac_smoother + use mld_z_as_smoother + use mld_z_diag_solver + use mld_z_ilu_solver + use mld_z_id_solver + use mld_z_gs_solver +#if defined(HAVE_UMF_) + use mld_z_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_z_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_z_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_z_mumps_solver +#endif + + Implicit None + + ! Arguments + class(mld_z_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='z_base_onelev_cseti' + type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold + type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold + type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold + type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold + type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold + type(mld_z_id_solver_type) :: mld_z_id_solver_mold + type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold + type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_z_sludist_solver_type) :: mld_z_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_z_slu_solver_type) :: mld_z_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_z_mumps_solver_type) :: mld_z_mumps_solver_mold +#endif + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (mld_noprec_) + call lv%set(mld_z_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_z_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case('SUB_SOLVE') + select case (val) + case (mld_f_none_) + call lv%set(mld_z_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_z_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_z_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_z_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_z_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_z_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_z_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + + case ('SMOOTHER_SWEEPS') + lv%parms%sweeps = val + lv%parms%sweeps_pre = val + lv%parms%sweeps_post = val + + case ('SMOOTHER_SWEEPS_PRE') + lv%parms%sweeps_pre = val + + case ('SMOOTHER_SWEEPS_POST') + lv%parms%sweeps_post = val + + case ('ML_TYPE') + lv%parms%ml_type = val + + case ('AGGR_ALG') + lv%parms%aggr_alg = val + + case ('AGGR_ORD') + lv%parms%aggr_ord = val + + case ('AGGR_KIND') + lv%parms%aggr_kind = val + + case ('COARSE_MAT') + lv%parms%coarse_mat = val + + case ('SMOOTHER_POS') + lv%parms%smoother_pos = val + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= val + + case ('AGGR_EIG') + lv%parms%aggr_eig = val + + case ('AGGR_FILTER') + lv%parms%aggr_filter = val + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = val + + case default + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + + end select + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_z_base_onelev_cseti diff --git a/mlprec/impl/level/mld_z_base_onelev_csetr.f90 b/mlprec/impl/level/mld_z_base_onelev_csetr.f90 index e6e8cc56..38425140 100644 --- a/mlprec/impl/level/mld_z_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_csetr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_csetr(lv,what,val,info) +subroutine mld_z_base_onelev_csetr(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_csetr @@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info) character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_csetr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_z_base_onelev_setc.f90 b/mlprec/impl/level/mld_z_base_onelev_setc.f90 index 7f1501dd..dd3f3acb 100644 --- a/mlprec/impl/level/mld_z_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_setc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_setc(lv,what,val,info) +subroutine mld_z_base_onelev_setc(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setc @@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info) integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_setc' integer(psb_ipk_) :: ival @@ -58,14 +60,36 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end if - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_z_base_onelev_seti.F90 b/mlprec/impl/level/mld_z_base_onelev_seti.F90 new file mode 100644 index 00000000..250a6522 --- /dev/null +++ b/mlprec/impl/level/mld_z_base_onelev_seti.F90 @@ -0,0 +1,251 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_base_onelev_seti(lv,what,val,info,pos) + + use psb_base_mod + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_seti + use mld_z_jac_smoother + use mld_z_as_smoother + use mld_z_diag_solver + use mld_z_ilu_solver + use mld_z_id_solver + use mld_z_gs_solver +#if defined(HAVE_UMF_) + use mld_z_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_z_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_z_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_z_mumps_solver +#endif + + Implicit None + + ! Arguments + class(mld_z_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='z_base_onelev_seti' + type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold + type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold + type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold + type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold + type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold + type(mld_z_id_solver_type) :: mld_z_id_solver_mold + type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold + type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_z_sludist_solver_type) :: mld_z_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_z_slu_solver_type) :: mld_z_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_z_mumps_solver_type) :: mld_z_mumps_solver_mold +#endif + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case (what) + + case (mld_smoother_type_) + select case (val) + case (mld_noprec_) + call lv%set(mld_z_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_z_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case(mld_sub_solve_) + select case (val) + case (mld_f_none_) + call lv%set(mld_z_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_z_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_z_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_z_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_z_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_z_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_z_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + case (mld_smoother_sweeps_) + lv%parms%sweeps = val + lv%parms%sweeps_pre = val + lv%parms%sweeps_post = val + + case (mld_smoother_sweeps_pre_) + lv%parms%sweeps_pre = val + + case (mld_smoother_sweeps_post_) + 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_ord_) + lv%parms%aggr_ord = 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 + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + + end select + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_z_base_onelev_seti diff --git a/mlprec/impl/level/mld_z_base_onelev_setr.f90 b/mlprec/impl/level/mld_z_base_onelev_setr.f90 index e18254ca..ec299235 100644 --- a/mlprec/impl/level/mld_z_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_setr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_setr(lv,what,val,info) +subroutine mld_z_base_onelev_setr(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setr @@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_setr(lv,what,val,info) integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_setr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_z_base_onelev_setr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_z_base_onelev_setsm.F90 b/mlprec/impl/level/mld_z_base_onelev_setsm.F90 new file mode 100644 index 00000000..f0ffd549 --- /dev/null +++ b/mlprec/impl/level/mld_z_base_onelev_setsm.F90 @@ -0,0 +1,107 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_base_onelev_setsm(lev,val,info,pos) + + use psb_base_mod + use mld_z_prec_mod, mld_protect_name => mld_z_base_onelev_setsm + + implicit none + + ! Arguments + class(mld_z_onelev_type), target, intent(inout) :: lev + class(mld_z_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (.not.same_type_as(lev%sm,val)) then + call lev%sm%free(info) + deallocate(lev%sm, stat=info) + end if + endif + if (.not.allocated(lev%sm)) then +#ifdef HAVE_MOLD + allocate(lev%sm,mold=val) +#else + allocate(lev%sm,source=val) +#endif + end if + call lev%sm%default() + lev%sm2 => lev%sm + case(mld_post_smooth_) + if (allocated(lev%sm2a)) then + if (.not.same_type_as(lev%sm2a,val)) then + call lev%sm2a%free(info) + deallocate(lev%sm2a, stat=info) + endif + end if + if (.not.allocated(lev%sm2a)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a,mold=val) +#else + allocate(lev%sm2a,source=val) +#endif + end if + call lev%sm2a%default() + lev%sm2 => lev%sm2a + end select + +end subroutine mld_z_base_onelev_setsm + diff --git a/mlprec/impl/level/mld_z_base_onelev_setsv.F90 b/mlprec/impl/level/mld_z_base_onelev_setsv.F90 new file mode 100644 index 00000000..2491cda3 --- /dev/null +++ b/mlprec/impl/level/mld_z_base_onelev_setsv.F90 @@ -0,0 +1,144 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_base_onelev_setsv(lev,val,info,pos) + + use psb_base_mod + use mld_z_prec_mod, mld_protect_name => mld_z_base_onelev_setsv + + implicit none + + ! Arguments + class(mld_z_onelev_type), target, intent(inout) :: lev + class(mld_z_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (allocated(lev%sm%sv)) then + if (.not.same_type_as(lev%sm%sv,val)) then + call lev%sm%sv%free(info) + deallocate(lev%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lev%sm%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm%sv,mold=val,stat=info) +#else + allocate(lev%sm%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + case(mld_post_smooth_) + + if (allocated(lev%sm2a)) then + if (allocated(lev%sm2a%sv)) then + if (.not.same_type_as(lev%sm2a%sv,val)) then + call lev%sm2a%sv%free(info) + deallocate(lev%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lev%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a%sv,mold=val,stat=info) +#else + allocate(lev%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm2a%sv%default() + + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end select + +end subroutine mld_z_base_onelev_setsv + diff --git a/mlprec/impl/mld_ccprecset.F90 b/mlprec/impl/mld_ccprecset.F90 index e4858649..86b1b413 100644 --- a/mlprec/impl/mld_ccprecset.F90 +++ b/mlprec/impl/mld_ccprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_ccprecseti(p,what,val,info,ilev) +subroutine mld_ccprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_ccprecseti @@ -102,6 +102,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -144,38 +145,20 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) ! ! Rules for fine level are slightly different. ! - select case(psb_toupper(trim(what))) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& - & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& - & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& - & 'SMOOTHER_SWEEPS_POST',& - & 'SUB_RESTR','SUB_PROL', & - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info) - - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(psb_toupper(what)) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& + case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',& + & 'ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN',& & 'COARSE_MAT') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case('COARSE_SUBSOLVE') if (ilev_ /= nlev_) then @@ -184,7 +167,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -192,38 +175,34 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) info = -2 return end if - + if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (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) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('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('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('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - + endif case('COARSE_SWEEPS') if (ilev_ /= nlev_) then @@ -232,7 +211,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) case('COARSE_FILLIN') if (ilev_ /= nlev_) then @@ -241,9 +220,10 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -254,33 +234,12 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case('SUB_RESTR','SUB_PROL',& - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_SWEEPS') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -288,334 +247,68 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_MAT',val,info) + call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos) end if case('COARSE_SOLVE') if (nlev_ > 1) then - - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) 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) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) +#elif defined(HAVE_MUMPS_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('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('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('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') if (nlev_ > 1) then - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) end if case('COARSE_FILLIN') if (nlev_ > 1) then - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_c_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), 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_c_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_gs_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_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_mumps_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_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if -#endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_ccprecseti ! @@ -657,7 +350,7 @@ end subroutine mld_ccprecseti ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_ccprecsetc(p,what,string,info,ilev) +subroutine mld_ccprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_ccprecsetc @@ -670,6 +363,7 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -698,9 +392,9 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev) val = mld_stringval(string) if (val >=0) then - call p%set(what,val,info,ilev=ilev) + call p%set(what,val,info,ilev=ilev,pos=pos) else - call p%precv(ilev_)%set(what,string,info) + call p%precv(ilev_)%set(what,string,info,pos=pos) end if end subroutine mld_ccprecsetc @@ -744,7 +438,7 @@ end subroutine mld_ccprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_ccprecsetr(p,what,val,info,ilev) +subroutine mld_ccprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_ccprecsetr @@ -757,6 +451,7 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev) real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -793,7 +488,7 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -803,19 +498,19 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev) select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ - call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set('AGGR_THRESH',thr,info) + call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index b421b093..4354f189 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -405,10 +405,10 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans + integer(psb_ipk_) :: level + type(mld_cprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -434,7 +434,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - if (level > 1) then nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() @@ -539,7 +538,6 @@ contains end if ! This is one step of post-smoothing - if (level < nlev) then call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then @@ -572,7 +570,7 @@ contains end if sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(cone,& + call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -621,13 +619,17 @@ contains ! if (level < nlev) then sweeps = p%precv(level)%parms%sweeps_post + call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else 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,& + & sweeps,work,info) end if - call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -830,6 +832,13 @@ contains case(mld_twoside_smooth_) + ! CHECK + if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then + write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) @@ -866,10 +875,19 @@ contains else 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,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -930,10 +948,18 @@ contains else 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,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -1043,7 +1069,7 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 call psb_geaxpby(cone,x,czero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%set(czero) + call mlprec_wrk(level)%vy2l%zero() call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -1090,12 +1116,12 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: level + type(mld_cprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt,np,me @@ -1122,7 +1148,9 @@ contains nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() - + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if select case(p%precv(level)%parms%ml_type) @@ -1160,7 +1188,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during ADD smoother_apply') goto 9999 end if @@ -1250,25 +1278,25 @@ contains sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(cone,& + call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%vx2l,cone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if else sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(cone,& + call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1302,13 +1330,13 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(cone,& + call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1386,7 +1414,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if @@ -1484,7 +1512,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if else @@ -1530,19 +1558,28 @@ contains if (level < nlev) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if else sweeps = p%precv(level)%parms%sweeps + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-PRE smoother_apply') goto 9999 end if @@ -1602,16 +1639,21 @@ contains ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-POST smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index a0f261b3..7acf5af1 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -495,10 +495,16 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - - if ((info == psb_success_).and.(i>1)) then - call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(i)%sm2a)) then + call p%precv(i)%sm2a%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(i)%sm2 => p%precv(i)%sm2a + else + p%precv(i)%sm2 => p%precv(i)%sm + end if end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') diff --git a/mlprec/impl/mld_cprecset.F90 b/mlprec/impl/mld_cprecset.F90 index 6728ca12..4b12a7e1 100644 --- a/mlprec/impl/mld_cprecset.F90 +++ b/mlprec/impl/mld_cprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_cprecseti(p,what,val,info,ilev) +subroutine mld_cprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecseti @@ -101,6 +101,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -141,39 +142,21 @@ subroutine mld_cprecseti(p,what,val,info,ilev) if (present(ilev)) then if (ilev_ == 1) then - ! - ! Rules for fine level are slightly different. - ! - select case(what) - 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_ord_,& - & 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 - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(what) - 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_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& + case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& + & 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_coarse_mat_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case(mld_coarse_subsolve_) if (ilev_ /= nlev_) then @@ -182,7 +165,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -192,30 +175,30 @@ subroutine mld_cprecseti(p,what,val,info,ilev) end if if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (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) + call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif @@ -226,7 +209,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) case(mld_coarse_fillin_) if (ilev_ /= nlev_) then @@ -235,9 +218,9 @@ subroutine mld_cprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -248,33 +231,12 @@ subroutine mld_cprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_) + case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - 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) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -282,336 +244,73 @@ subroutine mld_cprecseti(p,what,val,info,ilev) & 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) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_coarse_mat_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_mat_,val,info) + call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos) end if case(mld_coarse_solve_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) 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) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) end if case(mld_coarse_fillin_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_c_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), 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_c_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - - case (mld_diag_scale_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_gs_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_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set(mld_sub_solve_,val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_mumps_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_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_cprecseti -subroutine mld_cprecsetsm(p,val,info,ilev) +subroutine mld_cprecsetsm(p,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecsetsm @@ -623,6 +322,7 @@ subroutine mld_cprecsetsm(p,val,info,ilev) class(mld_c_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -658,23 +358,13 @@ subroutine mld_cprecsetsm(p,val,info,ilev) 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() + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do end subroutine mld_cprecsetsm -subroutine mld_cprecsetsv(p,val,info,ilev) +subroutine mld_cprecsetsv(p,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecsetsv @@ -686,6 +376,7 @@ subroutine mld_cprecsetsv(p,val,info,ilev) class(mld_c_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -720,43 +411,11 @@ subroutine mld_cprecsetsv(p,val,info,ilev) return endif - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - if (.not.allocated(p%precv(ilev_)%sm%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do - - end subroutine mld_cprecsetsv ! @@ -798,7 +457,7 @@ end subroutine mld_cprecsetsv ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_cprecsetc(p,what,string,info,ilev) +subroutine mld_cprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecsetc @@ -811,6 +470,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -838,7 +498,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev) endif val = mld_stringval(string) - if (val >=0) call p%set(what,val,info,ilev=ilev) + if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos) end subroutine mld_cprecsetc @@ -882,7 +542,7 @@ end subroutine mld_cprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_cprecsetr(p,what,val,info,ilev) +subroutine mld_cprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecsetr @@ -895,6 +555,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev) real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -931,7 +592,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -941,19 +602,19 @@ subroutine mld_cprecsetr(p,what,val,info,ilev) select case(what) case(mld_coarse_iluthrs_) ilev_=nlev_ - call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info) + call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) + call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 47782d44..ab02ed09 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dcprecseti(p,what,val,info,ilev) +subroutine mld_dcprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dcprecseti @@ -108,6 +108,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -150,38 +151,20 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) ! ! Rules for fine level are slightly different. ! - select case(psb_toupper(trim(what))) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& - & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& - & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& - & 'SMOOTHER_SWEEPS_POST',& - & 'SUB_RESTR','SUB_PROL', & - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info) - - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(psb_toupper(what)) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& + case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',& + & 'ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN',& & 'COARSE_MAT') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case('COARSE_SUBSOLVE') if (ilev_ /= nlev_) then @@ -190,7 +173,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -198,40 +181,36 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) info = -2 return end if - + if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) #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) + call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) +#elif defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('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('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('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - + endif case('COARSE_SWEEPS') if (ilev_ /= nlev_) then @@ -240,7 +219,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) case('COARSE_FILLIN') if (ilev_ /= nlev_) then @@ -249,9 +228,10 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -262,33 +242,12 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case('SUB_RESTR','SUB_PROL',& - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_SWEEPS') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -296,386 +255,70 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_MAT',val,info) + call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos) end if case('COARSE_SOLVE') if (nlev_ > 1) then - - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) #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) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) +#elif defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) +#elif defined(HAVE_MUMPS_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('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('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('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') if (nlev_ > 1) then - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) end if case('COARSE_FILLIN') if (nlev_ > 1) then - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), 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_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_gs_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_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_mumps_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_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if -#endif - -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_sludist_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_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_dcprecseti ! @@ -717,7 +360,7 @@ end subroutine mld_dcprecseti ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dcprecsetc(p,what,string,info,ilev) +subroutine mld_dcprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dcprecsetc @@ -730,6 +373,7 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -758,9 +402,9 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev) val = mld_stringval(string) if (val >=0) then - call p%set(what,val,info,ilev=ilev) + call p%set(what,val,info,ilev=ilev,pos=pos) else - call p%precv(ilev_)%set(what,string,info) + call p%precv(ilev_)%set(what,string,info,pos=pos) end if end subroutine mld_dcprecsetc @@ -804,7 +448,7 @@ end subroutine mld_dcprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dcprecsetr(p,what,val,info,ilev) +subroutine mld_dcprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dcprecsetr @@ -817,6 +461,7 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -853,7 +498,7 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -863,19 +508,19 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev) select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ - call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set('AGGR_THRESH',thr,info) + call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index 5aeabe1b..94f54e86 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -405,10 +405,10 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans + integer(psb_ipk_) :: level + type(mld_dprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -434,7 +434,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - if (level > 1) then nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() @@ -539,7 +538,6 @@ contains end if ! This is one step of post-smoothing - if (level < nlev) then call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then @@ -572,7 +570,7 @@ contains end if sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -583,6 +581,7 @@ contains end if else + ! Here at coarse level sweeps = p%precv(level)%parms%sweeps call p%precv(level)%sm%apply(done,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& @@ -621,13 +620,17 @@ contains ! if (level < nlev) then sweeps = p%precv(level)%parms%sweeps_post + call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else 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,& + & sweeps,work,info) end if - call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -830,6 +833,13 @@ contains case(mld_twoside_smooth_) + ! CHECK + if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then + write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) @@ -866,10 +876,19 @@ contains else 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,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -930,10 +949,18 @@ contains else 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,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -1043,7 +1070,7 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%set(dzero) + call mlprec_wrk(level)%vy2l%zero() call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -1090,12 +1117,12 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: level + type(mld_dprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt,np,me @@ -1122,7 +1149,9 @@ contains nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() - + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if select case(p%precv(level)%parms%ml_type) @@ -1160,7 +1189,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during ADD smoother_apply') goto 9999 end if @@ -1250,25 +1279,25 @@ contains sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%vx2l,done,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if else sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1302,13 +1331,13 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1386,7 +1415,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if @@ -1484,7 +1513,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if else @@ -1530,19 +1559,28 @@ contains if (level < nlev) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if else sweeps = p%precv(level)%parms%sweeps + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-PRE smoother_apply') goto 9999 end if @@ -1602,16 +1640,21 @@ contains ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-POST smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index 11409363..f88310ad 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -495,10 +495,16 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - - if ((info == psb_success_).and.(i>1)) then - call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(i)%sm2a)) then + call p%precv(i)%sm2a%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(i)%sm2 => p%precv(i)%sm2a + else + p%precv(i)%sm2 => p%precv(i)%sm + end if end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') diff --git a/mlprec/impl/mld_dprecbld.f90 b/mlprec/impl/mld_dprecbld.f90 index 65238515..28259f3d 100644 --- a/mlprec/impl/mld_dprecbld.f90 +++ b/mlprec/impl/mld_dprecbld.f90 @@ -173,15 +173,23 @@ subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold,imold) & a_err='One level preconditioner check.') goto 9999 endif - + call p%precv(1)%sm%build(a,desc_a,upd_,info,& & amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(1)%sm2a)) then + call p%precv(1)%sm%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(1)%sm2 => p%precv(1)%sm2a + else + p%precv(1)%sm2 => p%precv(i)%sm + end if + end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') goto 9999 endif - ! ! Number of levels > 1 ! diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 1a5fe0ef..cb1c50df 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dprecseti(p,what,val,info,ilev) +subroutine mld_dprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecseti @@ -107,6 +107,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -147,39 +148,21 @@ subroutine mld_dprecseti(p,what,val,info,ilev) if (present(ilev)) then if (ilev_ == 1) then - ! - ! Rules for fine level are slightly different. - ! - select case(what) - 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_ord_,& - & 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 - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(what) - 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_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& + case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& + & 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_coarse_mat_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case(mld_coarse_subsolve_) if (ilev_ /= nlev_) then @@ -188,7 +171,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -198,32 +181,32 @@ subroutine mld_dprecseti(p,what,val,info,ilev) end if if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif @@ -234,7 +217,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) case(mld_coarse_fillin_) if (ilev_ /= nlev_) then @@ -243,9 +226,9 @@ subroutine mld_dprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -256,33 +239,12 @@ subroutine mld_dprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_) + case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - 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) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -290,386 +252,75 @@ subroutine mld_dprecseti(p,what,val,info,ilev) & 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) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_coarse_mat_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_mat_,val,info) + call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos) end if case(mld_coarse_solve_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) end if case(mld_coarse_fillin_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), 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_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - - case (mld_diag_scale_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_gs_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_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set(mld_sub_solve_,val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_sludist_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_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_mumps_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_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_dprecseti -subroutine mld_dprecsetsm(p,val,info,ilev) +subroutine mld_dprecsetsm(p,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecsetsm @@ -681,6 +332,7 @@ subroutine mld_dprecsetsm(p,val,info,ilev) class(mld_d_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -716,23 +368,13 @@ subroutine mld_dprecsetsm(p,val,info,ilev) 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() + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do end subroutine mld_dprecsetsm -subroutine mld_dprecsetsv(p,val,info,ilev) +subroutine mld_dprecsetsv(p,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecsetsv @@ -744,6 +386,7 @@ subroutine mld_dprecsetsv(p,val,info,ilev) class(mld_d_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -778,43 +421,11 @@ subroutine mld_dprecsetsv(p,val,info,ilev) return endif - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - if (.not.allocated(p%precv(ilev_)%sm%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do - - end subroutine mld_dprecsetsv ! @@ -856,7 +467,7 @@ end subroutine mld_dprecsetsv ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dprecsetc(p,what,string,info,ilev) +subroutine mld_dprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecsetc @@ -869,6 +480,7 @@ subroutine mld_dprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -896,7 +508,7 @@ subroutine mld_dprecsetc(p,what,string,info,ilev) endif val = mld_stringval(string) - if (val >=0) call p%set(what,val,info,ilev=ilev) + if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos) end subroutine mld_dprecsetc @@ -940,7 +552,7 @@ end subroutine mld_dprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dprecsetr(p,what,val,info,ilev) +subroutine mld_dprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecsetr @@ -953,6 +565,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -989,7 +602,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -999,19 +612,19 @@ subroutine mld_dprecsetr(p,what,val,info,ilev) select case(what) case(mld_coarse_iluthrs_) ilev_=nlev_ - call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info) + call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) + call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_scprecset.F90 b/mlprec/impl/mld_scprecset.F90 index 5b80da49..70889de8 100644 --- a/mlprec/impl/mld_scprecset.F90 +++ b/mlprec/impl/mld_scprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_scprecseti(p,what,val,info,ilev) +subroutine mld_scprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_scprecseti @@ -102,6 +102,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -144,38 +145,20 @@ subroutine mld_scprecseti(p,what,val,info,ilev) ! ! Rules for fine level are slightly different. ! - select case(psb_toupper(trim(what))) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& - & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& - & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& - & 'SMOOTHER_SWEEPS_POST',& - & 'SUB_RESTR','SUB_PROL', & - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info) - - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(psb_toupper(what)) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& + case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',& + & 'ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN',& & 'COARSE_MAT') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case('COARSE_SUBSOLVE') if (ilev_ /= nlev_) then @@ -184,7 +167,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -192,38 +175,34 @@ subroutine mld_scprecseti(p,what,val,info,ilev) info = -2 return end if - + if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (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) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('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('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('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - + endif case('COARSE_SWEEPS') if (ilev_ /= nlev_) then @@ -232,7 +211,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) case('COARSE_FILLIN') if (ilev_ /= nlev_) then @@ -241,9 +220,10 @@ subroutine mld_scprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -254,33 +234,12 @@ subroutine mld_scprecseti(p,what,val,info,ilev) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case('SUB_RESTR','SUB_PROL',& - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_SWEEPS') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -288,334 +247,68 @@ subroutine mld_scprecseti(p,what,val,info,ilev) & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_MAT',val,info) + call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos) end if case('COARSE_SOLVE') if (nlev_ > 1) then - - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) 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) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) +#elif defined(HAVE_MUMPS_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('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('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('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') if (nlev_ > 1) then - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) end if case('COARSE_FILLIN') if (nlev_ > 1) then - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_s_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), 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) - 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_s_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_gs_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_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_mumps_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_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if -#endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_scprecseti ! @@ -657,7 +350,7 @@ end subroutine mld_scprecseti ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_scprecsetc(p,what,string,info,ilev) +subroutine mld_scprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_scprecsetc @@ -670,6 +363,7 @@ subroutine mld_scprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -698,9 +392,9 @@ subroutine mld_scprecsetc(p,what,string,info,ilev) val = mld_stringval(string) if (val >=0) then - call p%set(what,val,info,ilev=ilev) + call p%set(what,val,info,ilev=ilev,pos=pos) else - call p%precv(ilev_)%set(what,string,info) + call p%precv(ilev_)%set(what,string,info,pos=pos) end if end subroutine mld_scprecsetc @@ -744,7 +438,7 @@ end subroutine mld_scprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_scprecsetr(p,what,val,info,ilev) +subroutine mld_scprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_scprecsetr @@ -757,6 +451,7 @@ subroutine mld_scprecsetr(p,what,val,info,ilev) real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -793,7 +488,7 @@ subroutine mld_scprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -803,19 +498,19 @@ subroutine mld_scprecsetr(p,what,val,info,ilev) select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ - call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set('AGGR_THRESH',thr,info) + call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index 4dd1b108..f80db873 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -405,10 +405,10 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans + integer(psb_ipk_) :: level + type(mld_sprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -434,7 +434,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - if (level > 1) then nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() @@ -539,7 +538,6 @@ contains end if ! This is one step of post-smoothing - if (level < nlev) then call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then @@ -572,7 +570,7 @@ contains end if sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(sone,& + call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -621,13 +619,17 @@ contains ! if (level < nlev) then sweeps = p%precv(level)%parms%sweeps_post + call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else 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) end if - 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_) then call psb_errpush(psb_err_internal_error_,name,& @@ -830,6 +832,13 @@ contains case(mld_twoside_smooth_) + ! CHECK + if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then + write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) @@ -866,10 +875,19 @@ contains else 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,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + + if (trans == 'N') then + if (info == psb_success_) 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) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -930,10 +948,18 @@ contains else 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,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -1043,7 +1069,7 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 call psb_geaxpby(sone,x,szero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%set(szero) + call mlprec_wrk(level)%vy2l%zero() call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -1090,12 +1116,12 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: level + type(mld_sprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt,np,me @@ -1122,7 +1148,9 @@ contains nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() - + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if select case(p%precv(level)%parms%ml_type) @@ -1160,7 +1188,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during ADD smoother_apply') goto 9999 end if @@ -1250,25 +1278,25 @@ contains sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(sone,& + call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%vx2l,sone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if else sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(sone,& + call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1302,13 +1330,13 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(sone,& + call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1386,7 +1414,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if @@ -1484,7 +1512,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if else @@ -1530,19 +1558,28 @@ contains if (level < nlev) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if else sweeps = p%precv(level)%parms%sweeps + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-PRE smoother_apply') goto 9999 end if @@ -1602,16 +1639,21 @@ contains ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-POST smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index 3ea5518c..c76228dc 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -495,10 +495,16 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - - if ((info == psb_success_).and.(i>1)) then - call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(i)%sm2a)) then + call p%precv(i)%sm2a%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(i)%sm2 => p%precv(i)%sm2a + else + p%precv(i)%sm2 => p%precv(i)%sm + end if end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') diff --git a/mlprec/impl/mld_sprecset.F90 b/mlprec/impl/mld_sprecset.F90 index 822e1ea2..22da5c01 100644 --- a/mlprec/impl/mld_sprecset.F90 +++ b/mlprec/impl/mld_sprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_sprecseti(p,what,val,info,ilev) +subroutine mld_sprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecseti @@ -101,6 +101,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -141,39 +142,21 @@ subroutine mld_sprecseti(p,what,val,info,ilev) if (present(ilev)) then if (ilev_ == 1) then - ! - ! Rules for fine level are slightly different. - ! - select case(what) - 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_ord_,& - & 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 - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(what) - 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_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& + case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& + & 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_coarse_mat_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case(mld_coarse_subsolve_) if (ilev_ /= nlev_) then @@ -182,7 +165,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -192,30 +175,30 @@ subroutine mld_sprecseti(p,what,val,info,ilev) end if if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (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) + call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif @@ -226,7 +209,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) case(mld_coarse_fillin_) if (ilev_ /= nlev_) then @@ -235,9 +218,9 @@ subroutine mld_sprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -248,33 +231,12 @@ subroutine mld_sprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_) + case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - 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) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -282,336 +244,73 @@ subroutine mld_sprecseti(p,what,val,info,ilev) & 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) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_coarse_mat_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_mat_,val,info) + call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos) end if case(mld_coarse_solve_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) 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) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) end if case(mld_coarse_fillin_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_s_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), 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) - 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_s_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - - case (mld_diag_scale_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_gs_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_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set(mld_sub_solve_,val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_mumps_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_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_sprecseti -subroutine mld_sprecsetsm(p,val,info,ilev) +subroutine mld_sprecsetsm(p,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecsetsm @@ -623,6 +322,7 @@ subroutine mld_sprecsetsm(p,val,info,ilev) class(mld_s_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -658,23 +358,13 @@ subroutine mld_sprecsetsm(p,val,info,ilev) 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() + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do end subroutine mld_sprecsetsm -subroutine mld_sprecsetsv(p,val,info,ilev) +subroutine mld_sprecsetsv(p,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecsetsv @@ -686,6 +376,7 @@ subroutine mld_sprecsetsv(p,val,info,ilev) class(mld_s_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -720,43 +411,11 @@ subroutine mld_sprecsetsv(p,val,info,ilev) return endif - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - if (.not.allocated(p%precv(ilev_)%sm%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do - - end subroutine mld_sprecsetsv ! @@ -798,7 +457,7 @@ end subroutine mld_sprecsetsv ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_sprecsetc(p,what,string,info,ilev) +subroutine mld_sprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecsetc @@ -811,6 +470,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -838,7 +498,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev) endif val = mld_stringval(string) - if (val >=0) call p%set(what,val,info,ilev=ilev) + if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos) end subroutine mld_sprecsetc @@ -882,7 +542,7 @@ end subroutine mld_sprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_sprecsetr(p,what,val,info,ilev) +subroutine mld_sprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecsetr @@ -895,6 +555,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev) real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -931,7 +592,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -941,19 +602,19 @@ subroutine mld_sprecsetr(p,what,val,info,ilev) select case(what) case(mld_coarse_iluthrs_) ilev_=nlev_ - call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info) + call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) + call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_zcprecset.F90 b/mlprec/impl/mld_zcprecset.F90 index c75b80ce..e73b0d86 100644 --- a/mlprec/impl/mld_zcprecset.F90 +++ b/mlprec/impl/mld_zcprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zcprecseti(p,what,val,info,ilev) +subroutine mld_zcprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zcprecseti @@ -108,6 +108,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -150,38 +151,20 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) ! ! Rules for fine level are slightly different. ! - select case(psb_toupper(trim(what))) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& - & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& - & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& - & 'SMOOTHER_SWEEPS_POST',& - & 'SUB_RESTR','SUB_PROL', & - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info) - - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(psb_toupper(what)) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& + case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',& + & 'ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN',& & 'COARSE_MAT') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case('COARSE_SUBSOLVE') if (ilev_ /= nlev_) then @@ -190,7 +173,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -198,40 +181,36 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) info = -2 return end if - + if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) #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) + call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) +#elif defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('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('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('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - + endif case('COARSE_SWEEPS') if (ilev_ /= nlev_) then @@ -240,7 +219,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) case('COARSE_FILLIN') if (ilev_ /= nlev_) then @@ -249,9 +228,10 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -262,33 +242,12 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case('SUB_RESTR','SUB_PROL',& - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_SWEEPS') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -296,386 +255,70 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_MAT',val,info) + call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos) end if case('COARSE_SOLVE') if (nlev_ > 1) then - - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) #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) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) +#elif defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) +#elif defined(HAVE_MUMPS_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('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('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('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') if (nlev_ > 1) then - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) end if case('COARSE_FILLIN') if (nlev_ > 1) then - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_z_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), 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_z_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_gs_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_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_mumps_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_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if -#endif - -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_sludist_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_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_sludist_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_zcprecseti ! @@ -717,7 +360,7 @@ end subroutine mld_zcprecseti ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zcprecsetc(p,what,string,info,ilev) +subroutine mld_zcprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zcprecsetc @@ -730,6 +373,7 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -758,9 +402,9 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev) val = mld_stringval(string) if (val >=0) then - call p%set(what,val,info,ilev=ilev) + call p%set(what,val,info,ilev=ilev,pos=pos) else - call p%precv(ilev_)%set(what,string,info) + call p%precv(ilev_)%set(what,string,info,pos=pos) end if end subroutine mld_zcprecsetc @@ -804,7 +448,7 @@ end subroutine mld_zcprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zcprecsetr(p,what,val,info,ilev) +subroutine mld_zcprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zcprecsetr @@ -817,6 +461,7 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -853,7 +498,7 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -863,19 +508,19 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev) select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ - call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set('AGGR_THRESH',thr,info) + call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index bda0e5a2..6a4a3d02 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -405,10 +405,10 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans + integer(psb_ipk_) :: level + type(mld_zprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -434,7 +434,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - if (level > 1) then nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() @@ -539,7 +538,6 @@ contains end if ! This is one step of post-smoothing - if (level < nlev) then call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then @@ -572,7 +570,7 @@ contains end if sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(zone,& + call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%x2l,zone,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -621,13 +619,17 @@ contains ! if (level < nlev) then sweeps = p%precv(level)%parms%sweeps_post + call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else 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,& + & sweeps,work,info) end if - call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -830,6 +832,13 @@ contains case(mld_twoside_smooth_) + ! CHECK + if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then + write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) @@ -866,10 +875,19 @@ contains else 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,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -930,10 +948,18 @@ contains else 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,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -1043,7 +1069,7 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 call psb_geaxpby(zone,x,zzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%set(zzero) + call mlprec_wrk(level)%vy2l%zero() call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -1090,12 +1116,12 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: level + type(mld_zprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt,np,me @@ -1122,7 +1148,9 @@ contains nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() - + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if select case(p%precv(level)%parms%ml_type) @@ -1160,7 +1188,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during ADD smoother_apply') goto 9999 end if @@ -1250,25 +1278,25 @@ contains sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(zone,& + call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%vx2l,zone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if else sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(zone,& + call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1302,13 +1330,13 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(zone,& + call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1386,7 +1414,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if @@ -1484,7 +1512,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if else @@ -1530,19 +1558,28 @@ contains if (level < nlev) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if else sweeps = p%precv(level)%parms%sweeps + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-PRE smoother_apply') goto 9999 end if @@ -1602,16 +1639,21 @@ contains ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-POST smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index e833bfa3..ceea7e57 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -495,10 +495,16 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - - if ((info == psb_success_).and.(i>1)) then - call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(i)%sm2a)) then + call p%precv(i)%sm2a%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(i)%sm2 => p%precv(i)%sm2a + else + p%precv(i)%sm2 => p%precv(i)%sm + end if end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') diff --git a/mlprec/impl/mld_zprecset.F90 b/mlprec/impl/mld_zprecset.F90 index 7b46a90c..29aa699c 100644 --- a/mlprec/impl/mld_zprecset.F90 +++ b/mlprec/impl/mld_zprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zprecseti(p,what,val,info,ilev) +subroutine mld_zprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecseti @@ -107,6 +107,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -147,39 +148,21 @@ subroutine mld_zprecseti(p,what,val,info,ilev) if (present(ilev)) then if (ilev_ == 1) then - ! - ! Rules for fine level are slightly different. - ! - select case(what) - 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_ord_,& - & 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 - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(what) - 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_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& + case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& + & 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_coarse_mat_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case(mld_coarse_subsolve_) if (ilev_ /= nlev_) then @@ -188,7 +171,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -198,32 +181,32 @@ subroutine mld_zprecseti(p,what,val,info,ilev) end if if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif @@ -234,7 +217,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) case(mld_coarse_fillin_) if (ilev_ /= nlev_) then @@ -243,9 +226,9 @@ subroutine mld_zprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -256,33 +239,12 @@ subroutine mld_zprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_) + case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - 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) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -290,386 +252,75 @@ subroutine mld_zprecseti(p,what,val,info,ilev) & 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) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_coarse_mat_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_mat_,val,info) + call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos) end if case(mld_coarse_solve_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) end if case(mld_coarse_fillin_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_z_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), 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_z_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - - case (mld_diag_scale_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_gs_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_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set(mld_sub_solve_,val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_sludist_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_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_sludist_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - 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 - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_mumps_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_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_zprecseti -subroutine mld_zprecsetsm(p,val,info,ilev) +subroutine mld_zprecsetsm(p,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecsetsm @@ -681,6 +332,7 @@ subroutine mld_zprecsetsm(p,val,info,ilev) class(mld_z_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -716,23 +368,13 @@ subroutine mld_zprecsetsm(p,val,info,ilev) 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() + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do end subroutine mld_zprecsetsm -subroutine mld_zprecsetsv(p,val,info,ilev) +subroutine mld_zprecsetsv(p,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecsetsv @@ -744,6 +386,7 @@ subroutine mld_zprecsetsv(p,val,info,ilev) class(mld_z_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -778,43 +421,11 @@ subroutine mld_zprecsetsv(p,val,info,ilev) return endif - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - if (.not.allocated(p%precv(ilev_)%sm%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do - - end subroutine mld_zprecsetsv ! @@ -856,7 +467,7 @@ end subroutine mld_zprecsetsv ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zprecsetc(p,what,string,info,ilev) +subroutine mld_zprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecsetc @@ -869,6 +480,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -896,7 +508,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev) endif val = mld_stringval(string) - if (val >=0) call p%set(what,val,info,ilev=ilev) + if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos) end subroutine mld_zprecsetc @@ -940,7 +552,7 @@ end subroutine mld_zprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zprecsetr(p,what,val,info,ilev) +subroutine mld_zprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecsetr @@ -953,6 +565,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -989,7 +602,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -999,19 +612,19 @@ subroutine mld_zprecsetr(p,what,val,info,ilev) select case(what) case(mld_coarse_iluthrs_) ilev_=nlev_ - call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info) + call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) + call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/solver/Makefile b/mlprec/impl/solver/Makefile index 047aff65..d8040aa6 100644 --- a/mlprec/impl/solver/Makefile +++ b/mlprec/impl/solver/Makefile @@ -34,6 +34,9 @@ mld_c_gs_solver_cnv.o \ mld_c_gs_solver_dmp.o \ mld_c_gs_solver_apply.o \ mld_c_gs_solver_apply_vect.o \ +mld_c_bwgs_solver_bld.o \ +mld_c_bwgs_solver_apply.o \ +mld_c_bwgs_solver_apply_vect.o \ mld_c_id_solver_apply.o \ mld_c_id_solver_apply_vect.o \ mld_c_id_solver_clone.o \ @@ -66,6 +69,9 @@ mld_d_diag_solver_apply_vect.o \ mld_d_diag_solver_bld.o \ mld_d_diag_solver_clone.o \ mld_d_diag_solver_cnv.o \ +mld_d_bwgs_solver_bld.o \ +mld_d_bwgs_solver_apply.o \ +mld_d_bwgs_solver_apply_vect.o \ mld_d_gs_solver_bld.o \ mld_d_gs_solver_clone.o \ mld_d_gs_solver_cnv.o \ @@ -110,6 +116,9 @@ mld_s_gs_solver_cnv.o \ mld_s_gs_solver_dmp.o \ mld_s_gs_solver_apply.o \ mld_s_gs_solver_apply_vect.o \ +mld_s_bwgs_solver_bld.o \ +mld_s_bwgs_solver_apply.o \ +mld_s_bwgs_solver_apply_vect.o \ mld_s_id_solver_apply.o \ mld_s_id_solver_apply_vect.o \ mld_s_id_solver_clone.o \ @@ -148,6 +157,9 @@ mld_z_gs_solver_cnv.o \ mld_z_gs_solver_dmp.o \ mld_z_gs_solver_apply.o \ mld_z_gs_solver_apply_vect.o \ +mld_z_bwgs_solver_bld.o \ +mld_z_bwgs_solver_apply.o \ +mld_z_bwgs_solver_apply_vect.o \ mld_z_id_solver_apply.o \ mld_z_id_solver_apply_vect.o \ mld_z_id_solver_clone.o \ diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 new file mode 100644 index 00000000..ab47f90f --- /dev/null +++ b/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 @@ -0,0 +1,196 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_bwgs_solver_type), intent(inout) :: sv + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: temp(:),wv(:),xit(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + 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,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + 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,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(cone,x,czero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-cone,sv%l,xit,cone,wv,desc_data,info,doswap=.false.) + call psb_spsm(cone,sv%u,wv,czero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS 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 call psb_error_handler(err_act) + + return + +end subroutine mld_c_bwgs_solver_apply diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 new file mode 100644 index 00000000..101eb073 --- /dev/null +++ b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_bwgs_solver_type), intent(inout) :: sv + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + type(psb_c_vect_type) :: wv, xit + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: temp(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/itwo,n_row,izero,izero,izero/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/ithree,n_row,izero,izero,izero/)) + goto 9999 + end if + + + + 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) + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(cone,x,czero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-cone,sv%l,xit,cone,wv,desc_data,info,doswap=.false.) + call psb_spsm(cone,sv%u,wv,czero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS 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 + call wv%free(info) + call xit%free(info) + 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 call psb_error_handler(err_act) + + return + +end subroutine mld_c_bwgs_solver_apply_vect diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 new file mode 100644 index 00000000..daa62031 --- /dev/null +++ b/mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_bld + + Implicit None + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_c_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_bwgs_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 = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + + 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 + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info,diag=-1) + call a%triu(sv%u,info,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_c_bwgs_solver_bld diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 new file mode 100644 index 00000000..408f4a31 --- /dev/null +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 @@ -0,0 +1,196 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_bwgs_solver_type), intent(inout) :: sv + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: temp(:),wv(:),xit(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + 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,izero,izero,izero,izero/),& + & 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,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(done,x,dzero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-done,sv%l,xit,done,wv,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%u,wv,dzero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS 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 call psb_error_handler(err_act) + + return + +end subroutine mld_d_bwgs_solver_apply diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 new file mode 100644 index 00000000..6ec2ca50 --- /dev/null +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_bwgs_solver_type), intent(inout) :: sv + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + type(psb_d_vect_type) :: wv, xit + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: temp(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/itwo,n_row,izero,izero,izero/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/ithree,n_row,izero,izero,izero/)) + goto 9999 + end if + + + + 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) + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(done,x,dzero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-done,sv%l,xit,done,wv,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%u,wv,dzero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS 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 + call wv%free(info) + call xit%free(info) + 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 call psb_error_handler(err_act) + + return + +end subroutine mld_d_bwgs_solver_apply_vect diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 new file mode 100644 index 00000000..569eb35a --- /dev/null +++ b/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_bld + + Implicit None + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_d_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_bwgs_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 = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + + 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 + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info,diag=-1) + call a%triu(sv%u,info,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_d_bwgs_solver_bld diff --git a/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 index 38666ea0..3393fbbc 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 @@ -58,10 +58,9 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character :: trans_ character(len=20) :: name='d_mumps_solver_apply' -#if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) +#if defined(HAVE_MUMPS_) info = psb_success_ trans_ = psb_toupper(trans) select case(trans_) @@ -106,13 +105,13 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end select - sv%id%rhs => gx - sv%id%nrhs = 1 - sv%id%icntl(1) = -1 - sv%id%icntl(2) = -1 - sv%id%icntl(3) = -1 - sv%id%icntl(4) = -1 - sv%id%job = 3 + sv%id%rhs => gx + sv%id%nrhs = 1 + sv%id%icntl(1)=-1 + sv%id%icntl(2)=-1 + sv%id%icntl(3)=-1 + sv%id%icntl(4)=-1 + sv%id%job = 3 call dmumps(sv%id) call psb_scatter(gx, ww, desc_data, info, root=0) diff --git a/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 index c3462dd3..801066bb 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 @@ -79,5 +79,6 @@ #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif + end subroutine d_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_d_mumps_solver_bld.F90 b/mlprec/impl/solver/mld_d_mumps_solver_bld.F90 index dbf3c190..36b36883 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_bld.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_bld.F90 @@ -106,8 +106,8 @@ if (psb_toupper(upd) == 'F') then sv%id%comm = icomm - sv%id%job = -1 - sv%id%par = 1 + sv%id%job = -1 + sv%id%par=1 call dmumps(sv%id) !WARNING: CALLING dMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX sv%id%icntl(3)=sv%ipar(2) @@ -115,7 +115,7 @@ if (sv%ipar(1) < 0) then nglobrec=desc_a%get_local_rows() call a%csclip(c,info,jmax=a%get_nrows()) - call c%mv_to(acoo) + call c%cp_to(acoo) nglob = c%get_nrows() if (nglobrec /= nglob) then write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. A zero-overlap is used instead' @@ -130,10 +130,9 @@ call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I') end if - - sv%id%irn_loc => acoo%ia - sv%id%jcn_loc => acoo%ja - sv%id%a_loc => acoo%val + sv%id%irn_loc=> acoo%ia + sv%id%jcn_loc=> acoo%ja + sv%id%a_loc=> acoo%val sv%id%icntl(18)=3 if(acoo%is_upper() .or. acoo%is_lower()) then sv%id%sym = 2 @@ -144,7 +143,7 @@ ! there should be a better way for this sv%id%nz_loc = acoo%get_nzeros() sv%id%nz = acoo%get_nzeros() - sv%id%job = 4 + sv%id%job = 4 call psb_barrier(ictxt) write(*,*)'calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc call dmumps(sv%id) @@ -183,7 +182,6 @@ return end if return - #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 new file mode 100644 index 00000000..1be17289 --- /dev/null +++ b/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 @@ -0,0 +1,196 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_bwgs_solver_type), intent(inout) :: sv + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: temp(:),wv(:),xit(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + 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,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + 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,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(sone,x,szero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-sone,sv%l,xit,sone,wv,desc_data,info,doswap=.false.) + call psb_spsm(sone,sv%u,wv,szero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS 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 call psb_error_handler(err_act) + + return + +end subroutine mld_s_bwgs_solver_apply diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 new file mode 100644 index 00000000..4a9eb69e --- /dev/null +++ b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_bwgs_solver_type), intent(inout) :: sv + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + type(psb_s_vect_type) :: wv, xit + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: temp(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/itwo,n_row,izero,izero,izero/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/ithree,n_row,izero,izero,izero/)) + goto 9999 + end if + + + + 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) + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(sone,x,szero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-sone,sv%l,xit,sone,wv,desc_data,info,doswap=.false.) + call psb_spsm(sone,sv%u,wv,szero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS 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 + call wv%free(info) + call xit%free(info) + 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 call psb_error_handler(err_act) + + return + +end subroutine mld_s_bwgs_solver_apply_vect diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 new file mode 100644 index 00000000..af36fde0 --- /dev/null +++ b/mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_bld + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_bwgs_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 = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + + 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 + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info,diag=-1) + call a%triu(sv%u,info,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_s_bwgs_solver_bld diff --git a/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 index 9c01dd32..75e288f0 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 @@ -49,19 +49,18 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) 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(psb_ipk_), intent(out) :: info - integer :: n_row, n_col, nglob + integer(psb_ipk_) :: n_row, n_col, nglob real(psb_spk_), allocatable :: ww(:) real(psb_spk_), allocatable, target :: gx(:) - integer :: ictxt,np,me,i, err_act + integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_ character(len=20) :: name='s_mumps_solver_apply' -#if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) +#if defined(HAVE_MUMPS_) info = psb_success_ trans_ = psb_toupper(trans) select case(trans_) @@ -83,7 +82,7 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,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_)') + & a_err='real(psb_spk_)') goto 9999 end if end if @@ -91,7 +90,7 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) if (info /= psb_success_) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nglob,0,0,0,0/),& - & a_err='complex(psb_spk_)') + & a_err='real(psb_spk_)') goto 9999 end if call psb_gather(gx, x, desc_data, info, root=0) diff --git a/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 index 105fc6f5..0f6ad665 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 @@ -48,12 +48,13 @@ 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(psb_ipk_), intent(out) :: info - integer :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='s_mumps_solver_apply_vect' #if defined(HAVE_MUMPS_) + call psb_erractionsave(err_act) info = psb_success_ @@ -78,5 +79,6 @@ #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif + end subroutine s_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_s_mumps_solver_bld.F90 b/mlprec/impl/solver/mld_s_mumps_solver_bld.F90 index d52b33c1..ebeb3fc4 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_bld.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_bld.F90 @@ -51,7 +51,7 @@ Type(psb_desc_type), Intent(in) :: desc_a class(mld_s_mumps_solver_type), intent(inout) :: sv character, intent(in) :: upd - integer, intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_sspmat_type), intent(in), target, optional :: b class(psb_s_base_sparse_mat), intent(in), optional :: amold class(psb_s_base_vect_type), intent(in), optional :: vmold @@ -59,9 +59,9 @@ ! Local variables type(psb_sspmat_type) :: atmp type(psb_s_coo_sparse_mat), target :: acoo - integer :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc - integer :: ifrst, ibcheck - integer :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc + integer(psb_ipk_) :: ifrst, ibcheck + integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level character(len=20) :: name='s_mumps_solver_bld', ch_err #if defined(HAVE_MUMPS_) @@ -97,7 +97,7 @@ allocate(sv%id,stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ - call psb_errpush(info,name,a_err='mld_mumps_default') + call psb_errpush(info,name,a_err='mld_smumps_default') goto 9999 end if end if @@ -109,7 +109,7 @@ sv%id%job = -1 sv%id%par=1 call smumps(sv%id) - !WARNING: CALLING mumps WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX + !WARNING: CALLING sMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX sv%id%icntl(3)=sv%ipar(2) nglob = desc_a%get_global_rows() if (sv%ipar(1) < 0) then @@ -151,7 +151,7 @@ info = sv%id%infog(1) if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_mumps_fact ' + ch_err='mld_smumps_fact ' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if @@ -182,7 +182,6 @@ return end if return - #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 new file mode 100644 index 00000000..e5344433 --- /dev/null +++ b/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 @@ -0,0 +1,196 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_bwgs_solver_type), intent(inout) :: sv + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: temp(:),wv(:),xit(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + 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,izero,izero,izero,izero/),& + & a_err='complex(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,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(zone,x,zzero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-zone,sv%l,xit,zone,wv,desc_data,info,doswap=.false.) + call psb_spsm(zone,sv%u,wv,zzero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS 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 call psb_error_handler(err_act) + + return + +end subroutine mld_z_bwgs_solver_apply diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 new file mode 100644 index 00000000..809d9605 --- /dev/null +++ b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_bwgs_solver_type), intent(inout) :: sv + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + type(psb_z_vect_type) :: wv, xit + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: temp(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/itwo,n_row,izero,izero,izero/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/ithree,n_row,izero,izero,izero/)) + goto 9999 + end if + + + + 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) + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(zone,x,zzero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-zone,sv%l,xit,zone,wv,desc_data,info,doswap=.false.) + call psb_spsm(zone,sv%u,wv,zzero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS 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 + call wv%free(info) + call xit%free(info) + 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 call psb_error_handler(err_act) + + return + +end subroutine mld_z_bwgs_solver_apply_vect diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 new file mode 100644 index 00000000..1286bf8c --- /dev/null +++ b/mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_bld + + Implicit None + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_z_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_bwgs_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 = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + + 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 + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info,diag=-1) + call a%triu(sv%u,info,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_z_bwgs_solver_bld diff --git a/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 index f1b7c2e7..66348759 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 @@ -58,10 +58,9 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character :: trans_ character(len=20) :: name='z_mumps_solver_apply' -#if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) +#if defined(HAVE_MUMPS_) info = psb_success_ trans_ = psb_toupper(trans) select case(trans_) @@ -83,7 +82,7 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,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_)') + & a_err='complex(psb_dpk_)') goto 9999 end if end if @@ -91,7 +90,7 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) if (info /= psb_success_) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nglob,0,0,0,0/),& - & a_err='complex(psb_spk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if call psb_gather(gx, x, desc_data, info, root=0) @@ -144,6 +143,5 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine z_mumps_solver_apply diff --git a/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 index 831937a6..c895a549 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 @@ -79,5 +79,6 @@ #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif + end subroutine z_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_z_mumps_solver_bld.F90 b/mlprec/impl/solver/mld_z_mumps_solver_bld.F90 index a6c25457..199f3f46 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_bld.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_bld.F90 @@ -182,7 +182,6 @@ return end if return - #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 20826105..5e4619c8 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -179,28 +179,29 @@ module mld_base_prec_type ! ! Legal values for entry: mld_sub_solve_ ! - integer(psb_ipk_), parameter :: mld_slv_delta_ = mld_max_prec_+1 - integer(psb_ipk_), parameter :: mld_f_none_ = mld_slv_delta_+0 - integer(psb_ipk_), parameter :: mld_diag_scale_ = mld_slv_delta_+1 - integer(psb_ipk_), parameter :: mld_gs_ = mld_slv_delta_+2 - integer(psb_ipk_), parameter :: mld_ilu_n_ = mld_slv_delta_+3 - integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+4 - integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+5 - integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+6 - integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+7 - integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+8 - integer(psb_ipk_), parameter :: mld_mumps_ = mld_slv_delta_+9 - integer(psb_ipk_), parameter :: mld_max_sub_solve_= mld_slv_delta_+9 - integer(psb_ipk_), parameter :: mld_min_sub_solve_= mld_diag_scale_ + integer(psb_ipk_), parameter :: mld_slv_delta_ = mld_max_prec_+1 + integer(psb_ipk_), parameter :: mld_f_none_ = mld_slv_delta_+0 + integer(psb_ipk_), parameter :: mld_diag_scale_ = mld_slv_delta_+1 + integer(psb_ipk_), parameter :: mld_gs_ = mld_slv_delta_+2 + integer(psb_ipk_), parameter :: mld_ilu_n_ = mld_slv_delta_+3 + integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+4 + integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+5 + integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+6 + integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+7 + integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+8 + integer(psb_ipk_), parameter :: mld_mumps_ = mld_slv_delta_+9 + integer(psb_ipk_), parameter :: mld_bwgs_ = mld_slv_delta_+10 + integer(psb_ipk_), parameter :: mld_max_sub_solve_ = mld_slv_delta_+10 + integer(psb_ipk_), parameter :: mld_min_sub_solve_ = mld_diag_scale_ ! ! Legal values for entry: mld_sub_ren_ ! - integer(psb_ipk_), parameter :: mld_renum_none_=0 - integer(psb_ipk_), parameter :: mld_renum_glb_=1 - integer(psb_ipk_), parameter :: mld_renum_gps_=2 + integer(psb_ipk_), parameter :: mld_renum_none_ = 0 + integer(psb_ipk_), parameter :: mld_renum_glb_ = 1 + integer(psb_ipk_), parameter :: mld_renum_gps_ = 2 ! For the time being we are disabling GPS renumbering. - integer(psb_ipk_), parameter :: mld_max_renum_=1 + integer(psb_ipk_), parameter :: mld_max_renum_ = 1 ! ! Legal values for entry: mld_ilu_scale_ ! @@ -217,40 +218,40 @@ module mld_base_prec_type ! integer(psb_ipk_), parameter :: mld_no_ml_ = 0 integer(psb_ipk_), parameter :: mld_add_ml_ = 1 - integer(psb_ipk_), parameter :: mld_mult_ml_ = 2 + integer(psb_ipk_), parameter :: mld_mult_ml_ = 2 integer(psb_ipk_), parameter :: mld_new_ml_prec_ = 3 integer(psb_ipk_), parameter :: mld_max_ml_type_ = mld_mult_ml_ ! ! Legal values for entry: mld_smoother_pos_ ! - integer(psb_ipk_), parameter :: mld_pre_smooth_=1 - integer(psb_ipk_), parameter :: mld_post_smooth_=2 - integer(psb_ipk_), parameter :: mld_twoside_smooth_=3 - integer(psb_ipk_), parameter :: mld_max_smooth_=mld_twoside_smooth_ + integer(psb_ipk_), parameter :: mld_pre_smooth_ = 1 + integer(psb_ipk_), parameter :: mld_post_smooth_ = 2 + integer(psb_ipk_), parameter :: mld_twoside_smooth_ = 3 + integer(psb_ipk_), parameter :: mld_max_smooth_ = mld_twoside_smooth_ ! ! Legal values for entry: mld_aggr_kind_ ! - integer(psb_ipk_), parameter :: mld_no_smooth_ = 0 + integer(psb_ipk_), parameter :: mld_no_smooth_ = 0 integer(psb_ipk_), parameter :: mld_smooth_prol_ = 1 - integer(psb_ipk_), parameter :: mld_min_energy_ = 2 + integer(psb_ipk_), parameter :: mld_min_energy_ = 2 integer(psb_ipk_), parameter :: mld_biz_prol_ = 3 ! Disabling biz_prol for the time being. integer(psb_ipk_), parameter :: mld_max_aggr_kind_=mld_min_energy_ ! ! Legal values for entry: mld_aggr_filter_ ! - integer(psb_ipk_), parameter :: mld_no_filter_mat_=0 - integer(psb_ipk_), parameter :: mld_filter_mat_=1 - integer(psb_ipk_), parameter :: mld_max_filter_mat_=mld_no_filter_mat_ + integer(psb_ipk_), parameter :: mld_no_filter_mat_ = 0 + integer(psb_ipk_), parameter :: mld_filter_mat_ = 1 + integer(psb_ipk_), parameter :: mld_max_filter_mat_ = mld_no_filter_mat_ ! ! Legal values for entry: mld_aggr_alg_ ! - integer(psb_ipk_), parameter :: mld_dec_aggr_=0 - integer(psb_ipk_), parameter :: mld_sym_dec_aggr_=1 - integer(psb_ipk_), parameter :: mld_glb_aggr_=2 - integer(psb_ipk_), parameter :: mld_new_dec_aggr_=3 - integer(psb_ipk_), parameter :: mld_new_glb_aggr_=4 - integer(psb_ipk_), parameter :: mld_max_aggr_alg_=mld_sym_dec_aggr_ + integer(psb_ipk_), parameter :: mld_dec_aggr_ = 0 + integer(psb_ipk_), parameter :: mld_sym_dec_aggr_ = 1 + integer(psb_ipk_), parameter :: mld_glb_aggr_ = 2 + integer(psb_ipk_), parameter :: mld_new_dec_aggr_ = 3 + integer(psb_ipk_), parameter :: mld_new_glb_aggr_ = 4 + integer(psb_ipk_), parameter :: mld_max_aggr_alg_ = mld_sym_dec_aggr_ ! ! Legal values for entry: mld_aggr_ord_ ! @@ -260,22 +261,22 @@ module mld_base_prec_type ! ! Legal values for entry: mld_aggr_omega_alg_ ! - integer(psb_ipk_), parameter :: mld_eig_est_=0 - integer(psb_ipk_), parameter :: mld_user_choice_=999 + integer(psb_ipk_), parameter :: mld_eig_est_ = 0 + integer(psb_ipk_), parameter :: mld_user_choice_ = 999 ! ! Legal values for entry: mld_aggr_eig_ ! - integer(psb_ipk_), parameter :: mld_max_norm_=0 + integer(psb_ipk_), parameter :: mld_max_norm_ = 0 ! ! Legal values for entry: mld_coarse_mat_ ! - integer(psb_ipk_), parameter :: mld_distr_mat_=0 - integer(psb_ipk_), parameter :: mld_repl_mat_=1 - integer(psb_ipk_), parameter :: mld_max_coarse_mat_=mld_repl_mat_ + integer(psb_ipk_), parameter :: mld_distr_mat_ = 0 + integer(psb_ipk_), parameter :: mld_repl_mat_ = 1 + integer(psb_ipk_), parameter :: mld_max_coarse_mat_ = mld_repl_mat_ ! ! Legal values for entry: mld_prec_status_ ! - integer(psb_ipk_), parameter :: mld_prec_built_=98765 + integer(psb_ipk_), parameter :: mld_prec_built_ = 98765 ! ! Entries in rprcparm: ILU(k,t) threshold, smoothed aggregation omega @@ -293,22 +294,22 @@ module mld_base_prec_type ! Entries for mumps ! !parameter controling the sequential/parallel building of MUMPS - integer(psb_ipk_), parameter :: mld_as_sequential_ =40 + integer(psb_ipk_), parameter :: mld_as_sequential_ = 40 !parameter regulating the error printing of MUMPS integer(psb_ipk_), parameter :: mld_mumps_print_err_ = 41 ! ! Fields for sparse matrices ensembles stored in av() ! - integer(psb_ipk_), parameter :: mld_l_pr_=1 - integer(psb_ipk_), parameter :: mld_u_pr_=2 - integer(psb_ipk_), parameter :: mld_bp_ilu_avsz_=2 - integer(psb_ipk_), parameter :: mld_ap_nd_=3 - integer(psb_ipk_), parameter :: mld_ac_=4 - integer(psb_ipk_), parameter :: mld_sm_pr_t_=5 - integer(psb_ipk_), parameter :: mld_sm_pr_=6 - integer(psb_ipk_), parameter :: mld_smth_avsz_=6 - integer(psb_ipk_), parameter :: mld_max_avsz_=mld_smth_avsz_ + integer(psb_ipk_), parameter :: mld_l_pr_ = 1 + integer(psb_ipk_), parameter :: mld_u_pr_ = 2 + integer(psb_ipk_), parameter :: mld_bp_ilu_avsz_ = 2 + integer(psb_ipk_), parameter :: mld_ap_nd_ = 3 + integer(psb_ipk_), parameter :: mld_ac_ = 4 + integer(psb_ipk_), parameter :: mld_sm_pr_t_ = 5 + integer(psb_ipk_), parameter :: mld_sm_pr_ = 6 + integer(psb_ipk_), parameter :: mld_smth_avsz_ = 6 + integer(psb_ipk_), parameter :: mld_max_avsz_ = mld_smth_avsz_ ! ! Character constants used by mld_file_prec_descr @@ -343,7 +344,8 @@ module mld_base_prec_type & 'Gauss-Seidel ','ILU(n) ',& & 'MILU(n) ','ILU(t,n) ',& & 'SuperLU ','UMFPACK LU ',& - & 'SuperLU_Dist ','MUMPS '/) + & 'SuperLU_Dist ','MUMPS ',& + & 'Backward GS '/) interface mld_check_def module procedure mld_icheck_def, mld_scheck_def, mld_dcheck_def @@ -393,8 +395,10 @@ contains val = psb_avg_ case('FACT_NONE') val = mld_f_none_ - case('GS') + case('GS','FWGS') val = mld_gs_ + case('BWGS') + val = mld_bwgs_ case('ILU') val = mld_ilu_n_ case('MILU') diff --git a/mlprec/mld_c_gs_solver.f90 b/mlprec/mld_c_gs_solver.f90 index 7b074d78..19881bb4 100644 --- a/mlprec/mld_c_gs_solver.f90 +++ b/mlprec/mld_c_gs_solver.f90 @@ -74,15 +74,25 @@ module mld_c_gs_solver procedure, nopass :: is_iterative => d_gs_solver_is_iterative end type mld_c_gs_solver_type + type, extends(mld_c_gs_solver_type) :: mld_c_bwgs_solver_type + contains + procedure, pass(sv) :: build => mld_c_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_c_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_c_bwgs_solver_apply + procedure, nopass :: get_fmt => c_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => c_bwgs_solver_descr + end type mld_c_bwgs_solver_type - private :: d_gs_solver_bld, d_gs_solver_apply, & - & d_gs_solver_free, d_gs_solver_seti, & - & d_gs_solver_setc, d_gs_solver_setr,& - & d_gs_solver_descr, d_gs_solver_sizeof, & - & d_gs_solver_default, d_gs_solver_dmp, & - & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & - & d_gs_solver_get_fmt, d_gs_solver_check,& - & d_gs_solver_is_iterative + + private :: c_gs_solver_bld, c_gs_solver_apply, & + & c_gs_solver_free, c_gs_solver_seti, & + & c_gs_solver_setc, c_gs_solver_setr,& + & c_gs_solver_descr, c_gs_solver_sizeof, & + & c_gs_solver_default, c_gs_solver_dmp, & + & c_gs_solver_apply_vect, c_gs_solver_get_nzeros, & + & c_gs_solver_get_fmt, c_gs_solver_check,& + & c_gs_solver_is_iterative, & + & c_bwgs_solver_get_fmt, c_bwgs_solver_descr interface @@ -99,6 +109,19 @@ module mld_c_gs_solver complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_c_gs_solver_apply_vect + subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_bwgs_solver_type), intent(inout) :: sv + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_c_bwgs_solver_apply_vect end interface interface @@ -115,6 +138,19 @@ module mld_c_gs_solver complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_c_gs_solver_apply + subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_bwgs_solver_type), intent(inout) :: sv + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_c_bwgs_solver_apply end interface interface @@ -133,6 +169,21 @@ module mld_c_gs_solver class(psb_c_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_c_gs_solver_bld + subroutine mld_c_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_c_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_c_bwgs_solver_bld end interface interface @@ -452,10 +503,10 @@ contains endif if (sv%eps<=dzero) then - write(iout_,*) ' Gauss-Seidel iterative solver with ',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',& & sv%sweeps,' sweeps' else - write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',& & sv%eps,' and maxit', sv%sweeps end if @@ -500,7 +551,7 @@ contains implicit none character(len=32) :: val - val = "Gauss-Seidel solver" + val = "Forward Gauss-Seidel solver" end function d_gs_solver_get_fmt @@ -514,5 +565,50 @@ contains val = .true. end function d_gs_solver_is_iterative + + subroutine c_bwgs_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_c_bwgs_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_c_bwgs_solver_descr' + integer(psb_ipk_) :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + if (sv%eps<=dzero) then + write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine c_bwgs_solver_descr + + function c_bwgs_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Backward Gauss-Seidel solver" + end function c_bwgs_solver_get_fmt end module mld_c_gs_solver diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index e0115610..a95f0182 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -121,7 +121,8 @@ module mld_c_onelev_mod ! ! type mld_c_onelev_type - class(mld_c_base_smoother_type), allocatable :: sm + class(mld_c_base_smoother_type), allocatable :: sm, sm2a + class(mld_c_base_smoother_type), pointer :: sm2 => null() type(mld_sml_parms) :: parms type(psb_cspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -144,7 +145,10 @@ module mld_c_onelev_mod procedure, pass(lv) :: cseti => mld_c_base_onelev_cseti procedure, pass(lv) :: csetr => mld_c_base_onelev_csetr procedure, pass(lv) :: csetc => mld_c_base_onelev_csetc - generic, public :: set => seti, setr, setc, cseti, csetr, csetc + procedure, pass(lv) :: setsm => mld_c_base_onelev_setsm + procedure, pass(lv) :: setsv => mld_c_base_onelev_setsv + generic, public :: set => seti, setr, setc, & + & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => c_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros procedure, nopass :: stringval => mld_stringval @@ -213,7 +217,7 @@ module mld_c_onelev_mod end interface interface - subroutine mld_c_base_onelev_seti(lv,what,val,info) + subroutine mld_c_base_onelev_seti(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -224,11 +228,40 @@ module mld_c_onelev_mod integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_seti end interface + + interface + subroutine mld_c_base_onelev_setsm(lv,val,info,pos) + import :: psb_spk_, mld_c_onelev_type, mld_c_base_smoother_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_c_onelev_type), target, intent(inout) :: lv + class(mld_c_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_c_base_onelev_setsm + end interface interface - subroutine mld_c_base_onelev_setc(lv,what,val,info) + subroutine mld_c_base_onelev_setsv(lv,val,info,pos) + import :: psb_spk_, mld_c_onelev_type, mld_c_base_solver_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_c_onelev_type), target, intent(inout) :: lv + class(mld_c_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_c_base_onelev_setsv + end interface + + interface + subroutine mld_c_base_onelev_setc(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -238,11 +271,12 @@ module mld_c_onelev_mod integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_setc end interface interface - subroutine mld_c_base_onelev_setr(lv,what,val,info) + subroutine mld_c_base_onelev_setr(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -252,12 +286,13 @@ module mld_c_onelev_mod integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_setr end interface interface - subroutine mld_c_base_onelev_cseti(lv,what,val,info) + subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -268,11 +303,12 @@ module mld_c_onelev_mod character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_cseti end interface interface - subroutine mld_c_base_onelev_csetc(lv,what,val,info) + subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -282,11 +318,12 @@ module mld_c_onelev_mod character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_csetc end interface interface - subroutine mld_c_base_onelev_csetr(lv,what,val,info) + subroutine mld_c_base_onelev_csetr(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -296,6 +333,7 @@ module mld_c_onelev_mod character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_csetr end interface @@ -331,6 +369,8 @@ contains val = 0 if (allocated(lv%sm)) & & val = lv%sm%get_nzeros() + if (allocated(lv%sm2a)) & + & val = val + lv%sm2a%get_nzeros() end function c_base_onelev_get_nzeros function c_base_onelev_sizeof(lv) result(val) @@ -344,6 +384,7 @@ contains val = val + lv%ac%sizeof() val = val + lv%map%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof() + if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof() end function c_base_onelev_sizeof @@ -354,7 +395,7 @@ contains nullify(lv%base_a) nullify(lv%base_desc) - + nullify(lv%sm2) end subroutine c_base_onelev_nullify ! @@ -370,9 +411,9 @@ contains subroutine c_base_onelev_default(lv) Implicit None - + ! Arguments - class(mld_c_onelev_type), intent(inout) :: lv + class(mld_c_onelev_type), target, intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 @@ -390,6 +431,12 @@ contains lv%parms%aggr_thresh = szero if (allocated(lv%sm)) call lv%sm%default() + if (allocated(lv%sm2a)) then + call lv%sm2a%default() + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if return @@ -403,8 +450,8 @@ contains ! Arguments class(mld_c_onelev_type), target, intent(inout) :: lv - class(mld_c_onelev_type), intent(inout) :: lvout - integer(psb_ipk_), intent(out) :: info + class(mld_c_onelev_type), target, intent(inout) :: lvout + integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(lv%sm)) then @@ -415,6 +462,16 @@ contains if (info==psb_success_) deallocate(lvout%sm,stat=info) end if end if + if (allocated(lv%sm2a)) then + call lv%sm%clone(lvout%sm2a,info) + lvout%sm2 => lvout%sm2a + else + if (allocated(lvout%sm2a)) then + call lvout%sm2a%free(info) + if (info==psb_success_) deallocate(lvout%sm2a,stat=info) + end if + lvout%sm2 => lvout%sm + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) @@ -430,12 +487,21 @@ contains subroutine mld_c_onelev_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_c_onelev_type), intent(inout) :: a, b + type(mld_c_onelev_type), target, intent(inout) :: a, b integer(psb_ipk_), intent(out) :: info call b%free(info) b%parms = a%parms - call move_alloc(a%sm,b%sm) + if (associated(a%sm2,a%sm2a)) then + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + 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) diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index b5e7e0bb..331dd65a 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -91,74 +91,81 @@ module mld_c_prec_mod contains - subroutine mld_c_iprecsetsm(p,val,info) + subroutine mld_c_iprecsetsm(p,val,info,pos) type(mld_cprec_type), intent(inout) :: p class(mld_c_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(val,info) + call p%set(val,info,pos=pos) end subroutine mld_c_iprecsetsm - subroutine mld_c_iprecsetsv(p,val,info) + subroutine mld_c_iprecsetsv(p,val,info,pos) type(mld_cprec_type), intent(inout) :: p class(mld_c_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info - - call p%set(val,info) + character(len=*), optional, intent(in) :: pos + call p%set(val,info, pos=pos) end subroutine mld_c_iprecsetsv - subroutine mld_c_iprecseti(p,what,val,info) + subroutine mld_c_iprecseti(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_iprecseti - subroutine mld_c_iprecsetr(p,what,val,info) + subroutine mld_c_iprecsetr(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_iprecsetr - subroutine mld_c_iprecsetc(p,what,val,info) + subroutine mld_c_iprecsetc(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_iprecsetc - subroutine mld_c_cprecseti(p,what,val,info) + subroutine mld_c_cprecseti(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_cprecseti - subroutine mld_c_cprecsetr(p,what,val,info) + subroutine mld_c_cprecsetr(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_cprecsetr - subroutine mld_c_cprecsetc(p,what,val,info) + subroutine mld_c_cprecsetc(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_cprecsetc end module mld_c_prec_mod diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 6c61d95e..a0db145b 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -175,23 +175,25 @@ module mld_c_prec_type end interface interface - subroutine mld_cprecsetsm(prec,val,info,ilev) + subroutine mld_cprecsetsm(prec,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, mld_c_base_smoother_type, psb_ipk_ - class(mld_cprec_type), intent(inout) :: prec + class(mld_cprec_type), target, intent(inout):: prec class(mld_c_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecsetsm - subroutine mld_cprecsetsv(prec,val,info,ilev) + subroutine mld_cprecsetsv(prec,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, mld_c_base_solver_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec class(mld_c_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecsetsv - subroutine mld_cprecseti(prec,what,val,info,ilev) + subroutine mld_cprecseti(prec,what,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -199,8 +201,9 @@ module mld_c_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecseti - subroutine mld_cprecsetr(prec,what,val,info,ilev) + subroutine mld_cprecsetr(prec,what,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -208,8 +211,9 @@ module mld_c_prec_type real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecsetr - subroutine mld_cprecsetc(prec,what,string,info,ilev) + subroutine mld_cprecsetc(prec,what,string,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -217,8 +221,9 @@ module mld_c_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecsetc - subroutine mld_ccprecseti(prec,what,val,info,ilev) + subroutine mld_ccprecseti(prec,what,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -226,8 +231,9 @@ module mld_c_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_ccprecseti - subroutine mld_ccprecsetr(prec,what,val,info,ilev) + subroutine mld_ccprecsetr(prec,what,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -235,8 +241,9 @@ module mld_c_prec_type real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_ccprecsetr - subroutine mld_ccprecsetc(prec,what,string,info,ilev) + subroutine mld_ccprecsetc(prec,what,string,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -244,6 +251,7 @@ module mld_c_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_ccprecsetc end interface @@ -477,6 +485,18 @@ contains write(iout_,*) return end if + if (allocated(p%precv(1)%sm2a)) then + write(iout_,*) 'Post smoother details' + call p%precv(1)%sm2a%descr(info,iout=iout_) + if (nlev == 1) then + if (p%precv(1)%parms%sweeps > 1) then + write(iout_,*) ' Number of smoother sweeps : ',& + & p%precv(1)%parms%sweeps + end if + write(iout_,*) + return + end if + end if end if ! diff --git a/mlprec/mld_d_gs_solver.f90 b/mlprec/mld_d_gs_solver.f90 index 6599d4ec..72f22638 100644 --- a/mlprec/mld_d_gs_solver.f90 +++ b/mlprec/mld_d_gs_solver.f90 @@ -74,6 +74,15 @@ module mld_d_gs_solver procedure, nopass :: is_iterative => d_gs_solver_is_iterative end type mld_d_gs_solver_type + type, extends(mld_d_gs_solver_type) :: mld_d_bwgs_solver_type + contains + procedure, pass(sv) :: build => mld_d_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_d_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_d_bwgs_solver_apply + procedure, nopass :: get_fmt => d_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => d_bwgs_solver_descr + end type mld_d_bwgs_solver_type + private :: d_gs_solver_bld, d_gs_solver_apply, & & d_gs_solver_free, d_gs_solver_seti, & @@ -82,7 +91,8 @@ module mld_d_gs_solver & d_gs_solver_default, d_gs_solver_dmp, & & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & & d_gs_solver_get_fmt, d_gs_solver_check,& - & d_gs_solver_is_iterative + & d_gs_solver_is_iterative, & + & d_bwgs_solver_get_fmt, d_bwgs_solver_descr interface @@ -99,6 +109,19 @@ module mld_d_gs_solver real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_d_gs_solver_apply_vect + subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_d_bwgs_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_bwgs_solver_type), intent(inout) :: sv + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_d_bwgs_solver_apply_vect end interface interface @@ -115,6 +138,19 @@ module mld_d_gs_solver real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_d_gs_solver_apply + subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_d_bwgs_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_bwgs_solver_type), intent(inout) :: sv + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_d_bwgs_solver_apply end interface interface @@ -133,6 +169,21 @@ module mld_d_gs_solver class(psb_d_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_d_gs_solver_bld + subroutine mld_d_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + import :: psb_desc_type, mld_d_bwgs_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_d_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_d_bwgs_solver_bld end interface interface @@ -452,10 +503,10 @@ contains endif if (sv%eps<=dzero) then - write(iout_,*) ' Gauss-Seidel iterative solver with ',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',& & sv%sweeps,' sweeps' else - write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',& & sv%eps,' and maxit', sv%sweeps end if @@ -500,7 +551,7 @@ contains implicit none character(len=32) :: val - val = "Gauss-Seidel solver" + val = "Forward Gauss-Seidel solver" end function d_gs_solver_get_fmt @@ -514,5 +565,50 @@ contains val = .true. end function d_gs_solver_is_iterative + + subroutine d_bwgs_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_d_bwgs_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_d_bwgs_solver_descr' + integer(psb_ipk_) :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + if (sv%eps<=dzero) then + write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine d_bwgs_solver_descr + + function d_bwgs_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Backward Gauss-Seidel solver" + end function d_bwgs_solver_get_fmt end module mld_d_gs_solver diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index ee3b1b7f..cf519b45 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -121,7 +121,8 @@ module mld_d_onelev_mod ! ! type mld_d_onelev_type - class(mld_d_base_smoother_type), allocatable :: sm + class(mld_d_base_smoother_type), allocatable :: sm, sm2a + class(mld_d_base_smoother_type), pointer :: sm2 => null() type(mld_dml_parms) :: parms type(psb_dspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -144,7 +145,10 @@ module mld_d_onelev_mod procedure, pass(lv) :: cseti => mld_d_base_onelev_cseti procedure, pass(lv) :: csetr => mld_d_base_onelev_csetr procedure, pass(lv) :: csetc => mld_d_base_onelev_csetc - generic, public :: set => seti, setr, setc, cseti, csetr, csetc + procedure, pass(lv) :: setsm => mld_d_base_onelev_setsm + procedure, pass(lv) :: setsv => mld_d_base_onelev_setsv + generic, public :: set => seti, setr, setc, & + & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => d_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros procedure, nopass :: stringval => mld_stringval @@ -213,7 +217,7 @@ module mld_d_onelev_mod end interface interface - subroutine mld_d_base_onelev_seti(lv,what,val,info) + subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -224,11 +228,40 @@ module mld_d_onelev_mod integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_seti end interface + + interface + subroutine mld_d_base_onelev_setsm(lv,val,info,pos) + import :: psb_dpk_, mld_d_onelev_type, mld_d_base_smoother_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_d_onelev_type), target, intent(inout) :: lv + class(mld_d_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_d_base_onelev_setsm + end interface interface - subroutine mld_d_base_onelev_setc(lv,what,val,info) + subroutine mld_d_base_onelev_setsv(lv,val,info,pos) + import :: psb_dpk_, mld_d_onelev_type, mld_d_base_solver_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_d_onelev_type), target, intent(inout) :: lv + class(mld_d_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_d_base_onelev_setsv + end interface + + interface + subroutine mld_d_base_onelev_setc(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -238,11 +271,12 @@ module mld_d_onelev_mod integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_setc end interface interface - subroutine mld_d_base_onelev_setr(lv,what,val,info) + subroutine mld_d_base_onelev_setr(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -252,12 +286,13 @@ module mld_d_onelev_mod integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_setr end interface interface - subroutine mld_d_base_onelev_cseti(lv,what,val,info) + subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -268,11 +303,12 @@ module mld_d_onelev_mod character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_cseti end interface interface - subroutine mld_d_base_onelev_csetc(lv,what,val,info) + subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -282,11 +318,12 @@ module mld_d_onelev_mod character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_csetc end interface interface - subroutine mld_d_base_onelev_csetr(lv,what,val,info) + subroutine mld_d_base_onelev_csetr(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -296,6 +333,7 @@ module mld_d_onelev_mod character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_csetr end interface @@ -331,6 +369,8 @@ contains val = 0 if (allocated(lv%sm)) & & val = lv%sm%get_nzeros() + if (allocated(lv%sm2a)) & + & val = val + lv%sm2a%get_nzeros() end function d_base_onelev_get_nzeros function d_base_onelev_sizeof(lv) result(val) @@ -344,6 +384,7 @@ contains val = val + lv%ac%sizeof() val = val + lv%map%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof() + if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof() end function d_base_onelev_sizeof @@ -354,7 +395,7 @@ contains nullify(lv%base_a) nullify(lv%base_desc) - + nullify(lv%sm2) end subroutine d_base_onelev_nullify ! @@ -370,9 +411,9 @@ contains subroutine d_base_onelev_default(lv) Implicit None - + ! Arguments - class(mld_d_onelev_type), intent(inout) :: lv + class(mld_d_onelev_type), target, intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 @@ -390,6 +431,12 @@ contains lv%parms%aggr_thresh = dzero if (allocated(lv%sm)) call lv%sm%default() + if (allocated(lv%sm2a)) then + call lv%sm2a%default() + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if return @@ -403,8 +450,8 @@ contains ! Arguments class(mld_d_onelev_type), target, intent(inout) :: lv - class(mld_d_onelev_type), intent(inout) :: lvout - integer(psb_ipk_), intent(out) :: info + class(mld_d_onelev_type), target, intent(inout) :: lvout + integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(lv%sm)) then @@ -415,6 +462,16 @@ contains if (info==psb_success_) deallocate(lvout%sm,stat=info) end if end if + if (allocated(lv%sm2a)) then + call lv%sm%clone(lvout%sm2a,info) + lvout%sm2 => lvout%sm2a + else + if (allocated(lvout%sm2a)) then + call lvout%sm2a%free(info) + if (info==psb_success_) deallocate(lvout%sm2a,stat=info) + end if + lvout%sm2 => lvout%sm + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) @@ -430,12 +487,21 @@ contains subroutine mld_d_onelev_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_d_onelev_type), intent(inout) :: a, b + type(mld_d_onelev_type), target, intent(inout) :: a, b integer(psb_ipk_), intent(out) :: info call b%free(info) b%parms = a%parms - call move_alloc(a%sm,b%sm) + if (associated(a%sm2,a%sm2a)) then + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + 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) diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index a9474b96..f10a1d95 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -91,74 +91,81 @@ module mld_d_prec_mod contains - subroutine mld_d_iprecsetsm(p,val,info) + subroutine mld_d_iprecsetsm(p,val,info,pos) type(mld_dprec_type), intent(inout) :: p class(mld_d_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(val,info) + call p%set(val,info,pos=pos) end subroutine mld_d_iprecsetsm - subroutine mld_d_iprecsetsv(p,val,info) + subroutine mld_d_iprecsetsv(p,val,info,pos) type(mld_dprec_type), intent(inout) :: p class(mld_d_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info - - call p%set(val,info) + character(len=*), optional, intent(in) :: pos + call p%set(val,info, pos=pos) end subroutine mld_d_iprecsetsv - subroutine mld_d_iprecseti(p,what,val,info) + subroutine mld_d_iprecseti(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_iprecseti - subroutine mld_d_iprecsetr(p,what,val,info) + subroutine mld_d_iprecsetr(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_iprecsetr - subroutine mld_d_iprecsetc(p,what,val,info) + subroutine mld_d_iprecsetc(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_iprecsetc - subroutine mld_d_cprecseti(p,what,val,info) + subroutine mld_d_cprecseti(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_cprecseti - subroutine mld_d_cprecsetr(p,what,val,info) + subroutine mld_d_cprecsetr(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_cprecsetr - subroutine mld_d_cprecsetc(p,what,val,info) + subroutine mld_d_cprecsetc(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_cprecsetc end module mld_d_prec_mod diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 134baa15..e8ffc729 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -175,23 +175,25 @@ module mld_d_prec_type end interface interface - subroutine mld_dprecsetsm(prec,val,info,ilev) + subroutine mld_dprecsetsm(prec,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, mld_d_base_smoother_type, psb_ipk_ - class(mld_dprec_type), intent(inout) :: prec + class(mld_dprec_type), target, intent(inout):: prec class(mld_d_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetsm - subroutine mld_dprecsetsv(prec,val,info,ilev) + subroutine mld_dprecsetsv(prec,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, mld_d_base_solver_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec class(mld_d_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetsv - subroutine mld_dprecseti(prec,what,val,info,ilev) + subroutine mld_dprecseti(prec,what,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -199,8 +201,9 @@ module mld_d_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecseti - subroutine mld_dprecsetr(prec,what,val,info,ilev) + subroutine mld_dprecsetr(prec,what,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -208,8 +211,9 @@ module mld_d_prec_type real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetr - subroutine mld_dprecsetc(prec,what,string,info,ilev) + subroutine mld_dprecsetc(prec,what,string,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -217,8 +221,9 @@ module mld_d_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetc - subroutine mld_dcprecseti(prec,what,val,info,ilev) + subroutine mld_dcprecseti(prec,what,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -226,8 +231,9 @@ module mld_d_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dcprecseti - subroutine mld_dcprecsetr(prec,what,val,info,ilev) + subroutine mld_dcprecsetr(prec,what,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -235,8 +241,9 @@ module mld_d_prec_type real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dcprecsetr - subroutine mld_dcprecsetc(prec,what,string,info,ilev) + subroutine mld_dcprecsetc(prec,what,string,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -244,6 +251,7 @@ module mld_d_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dcprecsetc end interface @@ -477,6 +485,18 @@ contains write(iout_,*) return end if + if (allocated(p%precv(1)%sm2a)) then + write(iout_,*) 'Post smoother details' + call p%precv(1)%sm2a%descr(info,iout=iout_) + if (nlev == 1) then + if (p%precv(1)%parms%sweeps > 1) then + write(iout_,*) ' Number of smoother sweeps : ',& + & p%precv(1)%parms%sweeps + end if + write(iout_,*) + return + end if + end if end if ! diff --git a/mlprec/mld_s_gs_solver.f90 b/mlprec/mld_s_gs_solver.f90 index 7e040560..c37b3f23 100644 --- a/mlprec/mld_s_gs_solver.f90 +++ b/mlprec/mld_s_gs_solver.f90 @@ -74,15 +74,25 @@ module mld_s_gs_solver procedure, nopass :: is_iterative => d_gs_solver_is_iterative end type mld_s_gs_solver_type + type, extends(mld_s_gs_solver_type) :: mld_s_bwgs_solver_type + contains + procedure, pass(sv) :: build => mld_s_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_s_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_s_bwgs_solver_apply + procedure, nopass :: get_fmt => s_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => s_bwgs_solver_descr + end type mld_s_bwgs_solver_type - private :: d_gs_solver_bld, d_gs_solver_apply, & - & d_gs_solver_free, d_gs_solver_seti, & - & d_gs_solver_setc, d_gs_solver_setr,& - & d_gs_solver_descr, d_gs_solver_sizeof, & - & d_gs_solver_default, d_gs_solver_dmp, & - & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & - & d_gs_solver_get_fmt, d_gs_solver_check,& - & d_gs_solver_is_iterative + + private :: s_gs_solver_bld, s_gs_solver_apply, & + & s_gs_solver_free, s_gs_solver_seti, & + & s_gs_solver_setc, s_gs_solver_setr,& + & s_gs_solver_descr, s_gs_solver_sizeof, & + & s_gs_solver_default, s_gs_solver_dmp, & + & s_gs_solver_apply_vect, s_gs_solver_get_nzeros, & + & s_gs_solver_get_fmt, s_gs_solver_check,& + & s_gs_solver_is_iterative, & + & s_bwgs_solver_get_fmt, s_bwgs_solver_descr interface @@ -99,6 +109,19 @@ module mld_s_gs_solver real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_s_gs_solver_apply_vect + subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_bwgs_solver_type), intent(inout) :: sv + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_s_bwgs_solver_apply_vect end interface interface @@ -115,6 +138,19 @@ module mld_s_gs_solver real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_s_gs_solver_apply + subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_bwgs_solver_type), intent(inout) :: sv + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_s_bwgs_solver_apply end interface interface @@ -133,6 +169,21 @@ module mld_s_gs_solver class(psb_s_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_s_gs_solver_bld + subroutine mld_s_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_s_bwgs_solver_bld end interface interface @@ -452,10 +503,10 @@ contains endif if (sv%eps<=dzero) then - write(iout_,*) ' Gauss-Seidel iterative solver with ',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',& & sv%sweeps,' sweeps' else - write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',& & sv%eps,' and maxit', sv%sweeps end if @@ -500,7 +551,7 @@ contains implicit none character(len=32) :: val - val = "Gauss-Seidel solver" + val = "Forward Gauss-Seidel solver" end function d_gs_solver_get_fmt @@ -514,5 +565,50 @@ contains val = .true. end function d_gs_solver_is_iterative + + subroutine s_bwgs_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_s_bwgs_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_s_bwgs_solver_descr' + integer(psb_ipk_) :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + if (sv%eps<=dzero) then + write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine s_bwgs_solver_descr + + function s_bwgs_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Backward Gauss-Seidel solver" + end function s_bwgs_solver_get_fmt end module mld_s_gs_solver diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index 7122f167..a7d32a5a 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -121,7 +121,8 @@ module mld_s_onelev_mod ! ! type mld_s_onelev_type - class(mld_s_base_smoother_type), allocatable :: sm + class(mld_s_base_smoother_type), allocatable :: sm, sm2a + class(mld_s_base_smoother_type), pointer :: sm2 => null() type(mld_sml_parms) :: parms type(psb_sspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -144,7 +145,10 @@ module mld_s_onelev_mod procedure, pass(lv) :: cseti => mld_s_base_onelev_cseti procedure, pass(lv) :: csetr => mld_s_base_onelev_csetr procedure, pass(lv) :: csetc => mld_s_base_onelev_csetc - generic, public :: set => seti, setr, setc, cseti, csetr, csetc + procedure, pass(lv) :: setsm => mld_s_base_onelev_setsm + procedure, pass(lv) :: setsv => mld_s_base_onelev_setsv + generic, public :: set => seti, setr, setc, & + & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => s_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros procedure, nopass :: stringval => mld_stringval @@ -213,7 +217,7 @@ module mld_s_onelev_mod end interface interface - subroutine mld_s_base_onelev_seti(lv,what,val,info) + subroutine mld_s_base_onelev_seti(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -224,11 +228,40 @@ module mld_s_onelev_mod integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_seti end interface + + interface + subroutine mld_s_base_onelev_setsm(lv,val,info,pos) + import :: psb_spk_, mld_s_onelev_type, mld_s_base_smoother_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_s_onelev_type), target, intent(inout) :: lv + class(mld_s_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_s_base_onelev_setsm + end interface interface - subroutine mld_s_base_onelev_setc(lv,what,val,info) + subroutine mld_s_base_onelev_setsv(lv,val,info,pos) + import :: psb_spk_, mld_s_onelev_type, mld_s_base_solver_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_s_onelev_type), target, intent(inout) :: lv + class(mld_s_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_s_base_onelev_setsv + end interface + + interface + subroutine mld_s_base_onelev_setc(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -238,11 +271,12 @@ module mld_s_onelev_mod integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_setc end interface interface - subroutine mld_s_base_onelev_setr(lv,what,val,info) + subroutine mld_s_base_onelev_setr(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -252,12 +286,13 @@ module mld_s_onelev_mod integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_setr end interface interface - subroutine mld_s_base_onelev_cseti(lv,what,val,info) + subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -268,11 +303,12 @@ module mld_s_onelev_mod character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_cseti end interface interface - subroutine mld_s_base_onelev_csetc(lv,what,val,info) + subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -282,11 +318,12 @@ module mld_s_onelev_mod character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_csetc end interface interface - subroutine mld_s_base_onelev_csetr(lv,what,val,info) + subroutine mld_s_base_onelev_csetr(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -296,6 +333,7 @@ module mld_s_onelev_mod character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_csetr end interface @@ -331,6 +369,8 @@ contains val = 0 if (allocated(lv%sm)) & & val = lv%sm%get_nzeros() + if (allocated(lv%sm2a)) & + & val = val + lv%sm2a%get_nzeros() end function s_base_onelev_get_nzeros function s_base_onelev_sizeof(lv) result(val) @@ -344,6 +384,7 @@ contains val = val + lv%ac%sizeof() val = val + lv%map%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof() + if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof() end function s_base_onelev_sizeof @@ -354,7 +395,7 @@ contains nullify(lv%base_a) nullify(lv%base_desc) - + nullify(lv%sm2) end subroutine s_base_onelev_nullify ! @@ -370,9 +411,9 @@ contains subroutine s_base_onelev_default(lv) Implicit None - + ! Arguments - class(mld_s_onelev_type), intent(inout) :: lv + class(mld_s_onelev_type), target, intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 @@ -390,6 +431,12 @@ contains lv%parms%aggr_thresh = szero if (allocated(lv%sm)) call lv%sm%default() + if (allocated(lv%sm2a)) then + call lv%sm2a%default() + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if return @@ -403,8 +450,8 @@ contains ! Arguments class(mld_s_onelev_type), target, intent(inout) :: lv - class(mld_s_onelev_type), intent(inout) :: lvout - integer(psb_ipk_), intent(out) :: info + class(mld_s_onelev_type), target, intent(inout) :: lvout + integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(lv%sm)) then @@ -415,6 +462,16 @@ contains if (info==psb_success_) deallocate(lvout%sm,stat=info) end if end if + if (allocated(lv%sm2a)) then + call lv%sm%clone(lvout%sm2a,info) + lvout%sm2 => lvout%sm2a + else + if (allocated(lvout%sm2a)) then + call lvout%sm2a%free(info) + if (info==psb_success_) deallocate(lvout%sm2a,stat=info) + end if + lvout%sm2 => lvout%sm + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) @@ -430,12 +487,21 @@ contains subroutine mld_s_onelev_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_s_onelev_type), intent(inout) :: a, b + type(mld_s_onelev_type), target, intent(inout) :: a, b integer(psb_ipk_), intent(out) :: info call b%free(info) b%parms = a%parms - call move_alloc(a%sm,b%sm) + if (associated(a%sm2,a%sm2a)) then + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + 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) diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index c8c0e4b2..594c79a9 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -91,74 +91,81 @@ module mld_s_prec_mod contains - subroutine mld_s_iprecsetsm(p,val,info) + subroutine mld_s_iprecsetsm(p,val,info,pos) type(mld_sprec_type), intent(inout) :: p class(mld_s_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(val,info) + call p%set(val,info,pos=pos) end subroutine mld_s_iprecsetsm - subroutine mld_s_iprecsetsv(p,val,info) + subroutine mld_s_iprecsetsv(p,val,info,pos) type(mld_sprec_type), intent(inout) :: p class(mld_s_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info - - call p%set(val,info) + character(len=*), optional, intent(in) :: pos + call p%set(val,info, pos=pos) end subroutine mld_s_iprecsetsv - subroutine mld_s_iprecseti(p,what,val,info) + subroutine mld_s_iprecseti(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_iprecseti - subroutine mld_s_iprecsetr(p,what,val,info) + subroutine mld_s_iprecsetr(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_iprecsetr - subroutine mld_s_iprecsetc(p,what,val,info) + subroutine mld_s_iprecsetc(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_iprecsetc - subroutine mld_s_cprecseti(p,what,val,info) + subroutine mld_s_cprecseti(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_cprecseti - subroutine mld_s_cprecsetr(p,what,val,info) + subroutine mld_s_cprecsetr(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_cprecsetr - subroutine mld_s_cprecsetc(p,what,val,info) + subroutine mld_s_cprecsetc(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_cprecsetc end module mld_s_prec_mod diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 3b1d30f7..aa538f61 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -175,23 +175,25 @@ module mld_s_prec_type end interface interface - subroutine mld_sprecsetsm(prec,val,info,ilev) + subroutine mld_sprecsetsm(prec,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, mld_s_base_smoother_type, psb_ipk_ - class(mld_sprec_type), intent(inout) :: prec + class(mld_sprec_type), target, intent(inout):: prec class(mld_s_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecsetsm - subroutine mld_sprecsetsv(prec,val,info,ilev) + subroutine mld_sprecsetsv(prec,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, mld_s_base_solver_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec class(mld_s_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecsetsv - subroutine mld_sprecseti(prec,what,val,info,ilev) + subroutine mld_sprecseti(prec,what,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -199,8 +201,9 @@ module mld_s_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecseti - subroutine mld_sprecsetr(prec,what,val,info,ilev) + subroutine mld_sprecsetr(prec,what,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -208,8 +211,9 @@ module mld_s_prec_type real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecsetr - subroutine mld_sprecsetc(prec,what,string,info,ilev) + subroutine mld_sprecsetc(prec,what,string,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -217,8 +221,9 @@ module mld_s_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecsetc - subroutine mld_scprecseti(prec,what,val,info,ilev) + subroutine mld_scprecseti(prec,what,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -226,8 +231,9 @@ module mld_s_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_scprecseti - subroutine mld_scprecsetr(prec,what,val,info,ilev) + subroutine mld_scprecsetr(prec,what,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -235,8 +241,9 @@ module mld_s_prec_type real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_scprecsetr - subroutine mld_scprecsetc(prec,what,string,info,ilev) + subroutine mld_scprecsetc(prec,what,string,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -244,6 +251,7 @@ module mld_s_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_scprecsetc end interface @@ -477,6 +485,18 @@ contains write(iout_,*) return end if + if (allocated(p%precv(1)%sm2a)) then + write(iout_,*) 'Post smoother details' + call p%precv(1)%sm2a%descr(info,iout=iout_) + if (nlev == 1) then + if (p%precv(1)%parms%sweeps > 1) then + write(iout_,*) ' Number of smoother sweeps : ',& + & p%precv(1)%parms%sweeps + end if + write(iout_,*) + return + end if + end if end if ! diff --git a/mlprec/mld_z_gs_solver.f90 b/mlprec/mld_z_gs_solver.f90 index 1bbac45e..a9a13679 100644 --- a/mlprec/mld_z_gs_solver.f90 +++ b/mlprec/mld_z_gs_solver.f90 @@ -74,15 +74,25 @@ module mld_z_gs_solver procedure, nopass :: is_iterative => d_gs_solver_is_iterative end type mld_z_gs_solver_type + type, extends(mld_z_gs_solver_type) :: mld_z_bwgs_solver_type + contains + procedure, pass(sv) :: build => mld_z_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_z_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_z_bwgs_solver_apply + procedure, nopass :: get_fmt => z_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => z_bwgs_solver_descr + end type mld_z_bwgs_solver_type - private :: d_gs_solver_bld, d_gs_solver_apply, & - & d_gs_solver_free, d_gs_solver_seti, & - & d_gs_solver_setc, d_gs_solver_setr,& - & d_gs_solver_descr, d_gs_solver_sizeof, & - & d_gs_solver_default, d_gs_solver_dmp, & - & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & - & d_gs_solver_get_fmt, d_gs_solver_check,& - & d_gs_solver_is_iterative + + private :: z_gs_solver_bld, z_gs_solver_apply, & + & z_gs_solver_free, z_gs_solver_seti, & + & z_gs_solver_setc, z_gs_solver_setr,& + & z_gs_solver_descr, z_gs_solver_sizeof, & + & z_gs_solver_default, z_gs_solver_dmp, & + & z_gs_solver_apply_vect, z_gs_solver_get_nzeros, & + & z_gs_solver_get_fmt, z_gs_solver_check,& + & z_gs_solver_is_iterative, & + & z_bwgs_solver_get_fmt, z_bwgs_solver_descr interface @@ -99,6 +109,19 @@ module mld_z_gs_solver complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_z_gs_solver_apply_vect + subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_bwgs_solver_type), intent(inout) :: sv + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_z_bwgs_solver_apply_vect end interface interface @@ -115,6 +138,19 @@ module mld_z_gs_solver complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_z_gs_solver_apply + subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_bwgs_solver_type), intent(inout) :: sv + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_z_bwgs_solver_apply end interface interface @@ -133,6 +169,21 @@ module mld_z_gs_solver class(psb_z_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_z_gs_solver_bld + subroutine mld_z_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_z_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_z_bwgs_solver_bld end interface interface @@ -452,10 +503,10 @@ contains endif if (sv%eps<=dzero) then - write(iout_,*) ' Gauss-Seidel iterative solver with ',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',& & sv%sweeps,' sweeps' else - write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',& & sv%eps,' and maxit', sv%sweeps end if @@ -500,7 +551,7 @@ contains implicit none character(len=32) :: val - val = "Gauss-Seidel solver" + val = "Forward Gauss-Seidel solver" end function d_gs_solver_get_fmt @@ -514,5 +565,50 @@ contains val = .true. end function d_gs_solver_is_iterative + + subroutine z_bwgs_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_z_bwgs_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_z_bwgs_solver_descr' + integer(psb_ipk_) :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + if (sv%eps<=dzero) then + write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine z_bwgs_solver_descr + + function z_bwgs_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Backward Gauss-Seidel solver" + end function z_bwgs_solver_get_fmt end module mld_z_gs_solver diff --git a/mlprec/mld_z_mumps_solver.F90 b/mlprec/mld_z_mumps_solver.F90 deleted file mode 100644 index 5d9d318d..00000000 --- a/mlprec/mld_z_mumps_solver.F90 +++ /dev/null @@ -1,482 +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,2012,2013 -!!$ -!!$ 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_mumps_solver -#if defined(HAVE_MUMPS_) - use zmumps_struc_def -#endif - use mld_z_base_solver_mod - -#if defined(LONG_INTEGERS) - - type, extends(mld_z_base_solver_type) :: mld_z_mumps_solver_type - - end type mld_z_mumps_solver_type -#else - type, extends(mld_z_base_solver_type) :: mld_z_mumps_solver_type -#if defined(HAVE_MUMPS_) - type(zmumps_struc), allocatable :: id -#else - integer, allocatable :: id -#endif - integer(psb_ipk_),dimension(2) :: ipar - logical :: built=.false. - contains - procedure, pass(sv) :: build => z_mumps_solver_bld - procedure, pass(sv) :: apply_a => z_mumps_solver_apply - procedure, pass(sv) :: apply_v => z_mumps_solver_apply_vect - procedure, pass(sv) :: free => z_mumps_solver_free - procedure, pass(sv) :: descr => z_mumps_solver_descr - procedure, pass(sv) :: sizeof => z_mumps_solver_sizeof - procedure, pass(sv) :: seti => z_mumps_solver_seti - procedure, pass(sv) :: setr => z_mumps_solver_setr - procedure, pass(sv) :: cseti =>z_mumps_solver_cseti - procedure, pass(sv) :: csetr => z_mumps_solver_csetr - procedure, pass(sv) :: default => z_mumps_solver_default -#if defined(HAVE_FINAL) - - final :: z_mumps_solver_finalize -#endif - end type mld_z_mumps_solver_type - - - private :: z_mumps_solver_bld, z_mumps_solver_apply, & - & z_mumps_solver_free, z_mumps_solver_descr, & - & z_mumps_solver_sizeof, z_mumps_solver_apply_vect,& - & z_mumps_solver_seti, z_mumps_solver_setr, & - & z_mumps_solver_cseti, z_mumps_solver_csetri, & - & z_mumps_solver_default -#if defined(HAVE_FINAL) - private :: z_mumps_solver_finalize -#endif - - interface - subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) - import :: psb_desc_type, mld_z_mumps_solver_type, psb_z_vect_type, psb_dpk_, psb_spk_, & - & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_z_mumps_solver_type), intent(inout) :: sv - type(psb_z_vect_type),intent(inout) :: x - type(psb_z_vect_type),intent(inout) :: y - complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - complex(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='z_mumps_solver_apply_vect' - end subroutine z_mumps_solver_apply_vect - end interface - - interface - subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) - import :: psb_desc_type, mld_z_mumps_solver_type, psb_z_vect_type, psb_dpk_, psb_spk_, & - & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_z_mumps_solver_type), intent(inout) :: sv - complex(psb_dpk_),intent(inout) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - complex(psb_dpk_),target, intent(inout) :: work(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: n_row, n_col, nglob - complex(psb_dpk_), pointer :: ww(:) - complex(psb_dpk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='z_mumps_solver_apply' - end subroutine z_mumps_solver_apply - end interface - - interface - subroutine z_mumps_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) - - use mpi - import :: psb_desc_type, mld_z_mumps_solver_type, psb_z_vect_type, psb_dpk_, & - & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,& - & psb_ipk_, psb_i_base_vect_type - - Implicit None - - ! Arguments - type(psb_zspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a - class(mld_z_mumps_solver_type), intent(inout) :: sv - character, intent(in) :: upd - integer(psb_ipk_), intent(out) :: info - type(psb_zspmat_type), intent(in), target, optional :: b - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - end subroutine z_mumps_solver_bld - end interface - -contains - - subroutine z_mumps_solver_free(sv,info) - - Implicit None - - ! Arguments - class(mld_z_mumps_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(out) :: info - Integer(psb_ipk_) :: err_act - character(len=20) :: name='z_mumps_solver_free' - - call psb_erractionsave(err_act) -#if defined(HAVE_MUMPS_) - if (allocated(sv%id)) then - if (sv%built) then - sv%id%job = -2 - call zmumps(sv%id) - info = sv%id%infog(1) - if (info /= psb_success_) goto 9999 - end if - deallocate(sv%id) - sv%built=.false. - 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 -#endif - end subroutine z_mumps_solver_free - -#if defined(HAVE_FINAL) - subroutine z_mumps_solver_finalize(sv) - - Implicit None - - ! Arguments - type(mld_z_mumps_solver_type), intent(inout) :: sv - integer :: info - Integer :: err_act - character(len=20) :: name='z_mumps_solver_finalize' - - call sv%free(info) - - return - - end subroutine z_mumps_solver_finalize -#endif - - subroutine z_mumps_solver_descr(sv,info,iout,coarse) - - Implicit None - - ! Arguments - class(mld_z_mumps_solver_type), intent(in) :: sv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - logical, intent(in), optional :: coarse - - ! Local variables - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ictxt, me, np - character(len=20), parameter :: name='mld_z_mumps_solver_descr' - integer(psb_ipk_) :: iout_ - - call psb_erractionsave(err_act) - info = psb_success_ - if (present(iout)) then - iout_ = iout - else - iout_ = 6 - endif - - write(iout_,*) ' MUMPS 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_mumps_solver_descr - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!$ WARNING: OTHERS PARAMETERS OF MUMPS COULD BE ADDED. FOR THIS, ADD AN !!$ -!!$ INTEGER IN MLD_BASE_PREC_TYPE.F90 AND MODIFY SUBROUTINE SET !!$ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine z_mumps_solver_seti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_mumps_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='z_mumps_solver_seti' - - info = psb_success_ - call psb_erractionsave(err_act) - select case(what) -#if defined(HAVE_MUMPS_) - case(mld_as_sequential_) - sv%ipar(1)=val - case(mld_mumps_print_err_) - sv%ipar(2)=val - !case(mld_print_stat_) - ! sv%id%icntl(2)=val - ! sv%ipar(2)=val - !case(mld_print_glob_) - ! sv%id%icntl(3)=val - ! sv%ipar(3)=val -#endif - case default - call sv%mld_z_base_solver_type%set(what,val,info) - 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_mumps_solver_seti - - - subroutine z_mumps_solver_setr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_mumps_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='z_mumps_solver_setr' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(what) - case default - call sv%mld_z_base_solver_type%set(what,val,info) - 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_mumps_solver_setr - - subroutine z_mumps_solver_cseti(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_mumps_solver_type), intent(inout) :: sv - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, iwhat - character(len=20) :: name='z_mumps_solver_cseti' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(psb_toupper(what)) -#if defined(HAVE_MUMPS_) - case('SET_AS_SEQUENTIAL') - iwhat=mld_as_sequential_ - case('SET_MUMPS_PRINT_ERR') - iwhat=mld_mumps_print_err_ -#endif - case default - iwhat=-1 - end select - - if (iwhat >=0 ) then - call sv%set(iwhat,val,info) - else - call sv%mld_z_base_solver_type%set(what,val,info) - 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_mumps_solver_cseti - - subroutine z_mumps_solver_csetr(sv,what,val,info) - - Implicit None - - ! Arguments - class(mld_z_mumps_solver_type), intent(inout) :: sv - character(len=*), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, iwhat - character(len=20) :: name='z_mumps_solver_csetr' - - info = psb_success_ - call psb_erractionsave(err_act) - - select case(psb_toupper(what)) - case default - call sv%mld_z_base_solver_type%set(what,val,info) - end select - - if (iwhat >=0 ) then - call sv%set(iwhat,val,info) - else - call sv%mld_z_base_solver_type%set(what,val,info) - 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_mumps_solver_csetr - - !!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !! - subroutine z_mumps_solver_default(sv) - - Implicit none - - !Argument - class(mld_z_mumps_solver_type),intent(inout) :: sv - integer(psb_ipk_) :: info - integer(psb_ipk_) :: err_act,ictx,icomm - character(len=20) :: name='z_mumps_default' - - info = psb_success_ - call psb_erractionsave(err_act) - -#if defined(HAVE_MUMPS_) - if (.not.allocated(sv%id)) then - allocate(sv%id,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name,a_err='mld_zmumps_default') - goto 9999 - end if - sv%built=.false. - end if - - ! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed - ! sv%id%job = -1 - ! sv%id%par=1 - ! call dmumps(sv%id) - sv%ipar(1)=2 - !sv%ipar(10)=6 - !sv%ipar(11)=0 - !sv%ipar(12)=6 - -#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_mumps_solver_default - - function z_mumps_solver_sizeof(sv) result(val) - - implicit none - ! Arguments - class(mld_z_mumps_solver_type), intent(in) :: sv - integer(psb_long_int_k_) :: val - integer :: i -#if defined(HAVE_MUMPS_) - val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6 -#else - val = 0 -#endif - ! val = 2*psb_sizeof_int + psb_sizeof_dp - ! val = val + sv%symbsize - ! val = val + sv%numsize - return - end function z_mumps_solver_sizeof -#endif -end module mld_z_mumps_solver - diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index e94a7d5c..c1ae6c90 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -121,7 +121,8 @@ module mld_z_onelev_mod ! ! type mld_z_onelev_type - class(mld_z_base_smoother_type), allocatable :: sm + class(mld_z_base_smoother_type), allocatable :: sm, sm2a + class(mld_z_base_smoother_type), pointer :: sm2 => null() type(mld_dml_parms) :: parms type(psb_zspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -144,7 +145,10 @@ module mld_z_onelev_mod procedure, pass(lv) :: cseti => mld_z_base_onelev_cseti procedure, pass(lv) :: csetr => mld_z_base_onelev_csetr procedure, pass(lv) :: csetc => mld_z_base_onelev_csetc - generic, public :: set => seti, setr, setc, cseti, csetr, csetc + procedure, pass(lv) :: setsm => mld_z_base_onelev_setsm + procedure, pass(lv) :: setsv => mld_z_base_onelev_setsv + generic, public :: set => seti, setr, setc, & + & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => z_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros procedure, nopass :: stringval => mld_stringval @@ -213,7 +217,7 @@ module mld_z_onelev_mod end interface interface - subroutine mld_z_base_onelev_seti(lv,what,val,info) + subroutine mld_z_base_onelev_seti(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -224,11 +228,40 @@ module mld_z_onelev_mod integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_seti end interface + + interface + subroutine mld_z_base_onelev_setsm(lv,val,info,pos) + import :: psb_dpk_, mld_z_onelev_type, mld_z_base_smoother_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_z_onelev_type), target, intent(inout) :: lv + class(mld_z_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_z_base_onelev_setsm + end interface interface - subroutine mld_z_base_onelev_setc(lv,what,val,info) + subroutine mld_z_base_onelev_setsv(lv,val,info,pos) + import :: psb_dpk_, mld_z_onelev_type, mld_z_base_solver_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_z_onelev_type), target, intent(inout) :: lv + class(mld_z_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_z_base_onelev_setsv + end interface + + interface + subroutine mld_z_base_onelev_setc(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -238,11 +271,12 @@ module mld_z_onelev_mod integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_setc end interface interface - subroutine mld_z_base_onelev_setr(lv,what,val,info) + subroutine mld_z_base_onelev_setr(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -252,12 +286,13 @@ module mld_z_onelev_mod integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_setr end interface interface - subroutine mld_z_base_onelev_cseti(lv,what,val,info) + subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -268,11 +303,12 @@ module mld_z_onelev_mod character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_cseti end interface interface - subroutine mld_z_base_onelev_csetc(lv,what,val,info) + subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -282,11 +318,12 @@ module mld_z_onelev_mod character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_csetc end interface interface - subroutine mld_z_base_onelev_csetr(lv,what,val,info) + subroutine mld_z_base_onelev_csetr(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -296,6 +333,7 @@ module mld_z_onelev_mod character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_csetr end interface @@ -331,6 +369,8 @@ contains val = 0 if (allocated(lv%sm)) & & val = lv%sm%get_nzeros() + if (allocated(lv%sm2a)) & + & val = val + lv%sm2a%get_nzeros() end function z_base_onelev_get_nzeros function z_base_onelev_sizeof(lv) result(val) @@ -344,6 +384,7 @@ contains val = val + lv%ac%sizeof() val = val + lv%map%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof() + if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof() end function z_base_onelev_sizeof @@ -354,7 +395,7 @@ contains nullify(lv%base_a) nullify(lv%base_desc) - + nullify(lv%sm2) end subroutine z_base_onelev_nullify ! @@ -370,9 +411,9 @@ contains subroutine z_base_onelev_default(lv) Implicit None - + ! Arguments - class(mld_z_onelev_type), intent(inout) :: lv + class(mld_z_onelev_type), target, intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 @@ -390,6 +431,12 @@ contains lv%parms%aggr_thresh = dzero if (allocated(lv%sm)) call lv%sm%default() + if (allocated(lv%sm2a)) then + call lv%sm2a%default() + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if return @@ -403,8 +450,8 @@ contains ! Arguments class(mld_z_onelev_type), target, intent(inout) :: lv - class(mld_z_onelev_type), intent(inout) :: lvout - integer(psb_ipk_), intent(out) :: info + class(mld_z_onelev_type), target, intent(inout) :: lvout + integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(lv%sm)) then @@ -415,6 +462,16 @@ contains if (info==psb_success_) deallocate(lvout%sm,stat=info) end if end if + if (allocated(lv%sm2a)) then + call lv%sm%clone(lvout%sm2a,info) + lvout%sm2 => lvout%sm2a + else + if (allocated(lvout%sm2a)) then + call lvout%sm2a%free(info) + if (info==psb_success_) deallocate(lvout%sm2a,stat=info) + end if + lvout%sm2 => lvout%sm + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) @@ -430,12 +487,21 @@ contains subroutine mld_z_onelev_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_z_onelev_type), intent(inout) :: a, b + type(mld_z_onelev_type), target, intent(inout) :: a, b integer(psb_ipk_), intent(out) :: info call b%free(info) b%parms = a%parms - call move_alloc(a%sm,b%sm) + if (associated(a%sm2,a%sm2a)) then + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + 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) diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index b1259522..1360c6cc 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -91,74 +91,81 @@ module mld_z_prec_mod contains - subroutine mld_z_iprecsetsm(p,val,info) + subroutine mld_z_iprecsetsm(p,val,info,pos) type(mld_zprec_type), intent(inout) :: p class(mld_z_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(val,info) + call p%set(val,info,pos=pos) end subroutine mld_z_iprecsetsm - subroutine mld_z_iprecsetsv(p,val,info) + subroutine mld_z_iprecsetsv(p,val,info,pos) type(mld_zprec_type), intent(inout) :: p class(mld_z_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info - - call p%set(val,info) + character(len=*), optional, intent(in) :: pos + call p%set(val,info, pos=pos) end subroutine mld_z_iprecsetsv - subroutine mld_z_iprecseti(p,what,val,info) + subroutine mld_z_iprecseti(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_iprecseti - subroutine mld_z_iprecsetr(p,what,val,info) + subroutine mld_z_iprecsetr(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_iprecsetr - subroutine mld_z_iprecsetc(p,what,val,info) + subroutine mld_z_iprecsetc(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_iprecsetc - subroutine mld_z_cprecseti(p,what,val,info) + subroutine mld_z_cprecseti(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_cprecseti - subroutine mld_z_cprecsetr(p,what,val,info) + subroutine mld_z_cprecsetr(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_cprecsetr - subroutine mld_z_cprecsetc(p,what,val,info) + subroutine mld_z_cprecsetc(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_cprecsetc end module mld_z_prec_mod diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index 0eda8dd0..d5a47aab 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -175,23 +175,25 @@ module mld_z_prec_type end interface interface - subroutine mld_zprecsetsm(prec,val,info,ilev) + subroutine mld_zprecsetsm(prec,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, mld_z_base_smoother_type, psb_ipk_ - class(mld_zprec_type), intent(inout) :: prec + class(mld_zprec_type), target, intent(inout):: prec class(mld_z_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecsetsm - subroutine mld_zprecsetsv(prec,val,info,ilev) + subroutine mld_zprecsetsv(prec,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, mld_z_base_solver_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec class(mld_z_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecsetsv - subroutine mld_zprecseti(prec,what,val,info,ilev) + subroutine mld_zprecseti(prec,what,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -199,8 +201,9 @@ module mld_z_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecseti - subroutine mld_zprecsetr(prec,what,val,info,ilev) + subroutine mld_zprecsetr(prec,what,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -208,8 +211,9 @@ module mld_z_prec_type real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecsetr - subroutine mld_zprecsetc(prec,what,string,info,ilev) + subroutine mld_zprecsetc(prec,what,string,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -217,8 +221,9 @@ module mld_z_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecsetc - subroutine mld_zcprecseti(prec,what,val,info,ilev) + subroutine mld_zcprecseti(prec,what,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -226,8 +231,9 @@ module mld_z_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zcprecseti - subroutine mld_zcprecsetr(prec,what,val,info,ilev) + subroutine mld_zcprecsetr(prec,what,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -235,8 +241,9 @@ module mld_z_prec_type real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zcprecsetr - subroutine mld_zcprecsetc(prec,what,string,info,ilev) + subroutine mld_zcprecsetc(prec,what,string,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -244,6 +251,7 @@ module mld_z_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zcprecsetc end interface @@ -477,6 +485,18 @@ contains write(iout_,*) return end if + if (allocated(p%precv(1)%sm2a)) then + write(iout_,*) 'Post smoother details' + call p%precv(1)%sm2a%descr(info,iout=iout_) + if (nlev == 1) then + if (p%precv(1)%parms%sweeps > 1) then + write(iout_,*) ' Number of smoother sweeps : ',& + & p%precv(1)%parms%sweeps + end if + write(iout_,*) + return + end if + end if end if ! diff --git a/tests/fileread/Makefile b/tests/fileread/Makefile index 66eb1778..fab2fe96 100644 --- a/tests/fileread/Makefile +++ b/tests/fileread/Makefile @@ -16,7 +16,8 @@ ZFSOBJS=zf_sample.o data_input.o EXEDIR=./runs -all: sf_sample df_sample cf_sample zf_sample df_sample_alya +all: sf_sample df_sample cf_sample zf_sample +#df_sample_alya df-sample_aya: df-sample_aya.o $(F90LINK) $(LINKOPT) $(DFSAYAOBJS) -o df-sample_aya \ diff --git a/tests/fileread/cf_sample.f90 b/tests/fileread/cf_sample.f90 index 26cd7adf..8b409d7c 100644 --- a/tests/fileread/cf_sample.f90 +++ b/tests/fileread/cf_sample.f90 @@ -62,6 +62,7 @@ program cf_sample integer(psb_ipk_) :: nlev ! number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed, raw aggregation character(len=16) :: aggr_alg ! aggregation algorithm (currently only decoupled) + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative multi-level prec character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: cmat ! coarse mat: distributed, replicated @@ -71,6 +72,7 @@ program cf_sample real(psb_spk_) :: cthres ! threshold for coarse fact. ILU(T) integer(psb_ipk_) :: cjswp ! block-Jacobi sweeps real(psb_spk_) :: athres ! smoothed aggregation threshold + real(psb_spk_) :: ascale ! smoothed aggregation scale factor end type precdata type(precdata) :: prec_choice @@ -260,12 +262,14 @@ program cf_sample call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) + call mld_precset(prec,mld_aggr_ord_, prec_choice%aggr_ord,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) call mld_precset(prec,mld_smoother_pos_, prec_choice%smthpos, info) + call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) @@ -276,15 +280,16 @@ program cf_sample else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) - call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) - call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) - call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) - call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) - call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + if (psb_toupper(prec_choice%prec) /= 'NONE') then + call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) + call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) + call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) + call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + end if end if - ! building the preconditioner t1 = psb_wtime() call mld_precbld(a,desc_a,prec,info) @@ -336,6 +341,8 @@ program cf_sample write(psb_out_unit,'("Total memory occupation for A : ",i12)')amatsize write(psb_out_unit,'("Total memory occupation for DESC_A : ",i12)')descsize write(psb_out_unit,'("Total memory occupation for PREC : ",i12)')precsize + write(psb_out_unit,'("Storage format for A : ",a )')a%get_fmt() + write(psb_out_unit,'("Storage format for DESC_A : ",a )')desc_a%get_fmt() end if call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) @@ -366,6 +373,7 @@ program cf_sample call psb_spfree(a, desc_a,info) call mld_precfree(prec,info) call psb_cdfree(desc_a,info) + call psb_exit(ictxt) stop @@ -418,15 +426,17 @@ contains call read_data(prec%smther,psb_inp_unit) ! Smoother type. call read_data(prec%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prec%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prec%aggr_ord,psb_inp_unit) ! Ordering for aggregation call read_data(prec%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prec%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prec%cmat,psb_inp_unit) ! coarse mat - call read_data(prec%csolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%csolve,psb_inp_unit) ! Factorization type: BJAC, SuperLU, UMFPACK. call read_data(prec%csbsolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. call read_data(prec%cfill,psb_inp_unit) ! Fill-in for factorization call read_data(prec%cthres,psb_inp_unit) ! Threshold for fact. ILU(T) call read_data(prec%cjswp,psb_inp_unit) ! Jacobi sweeps call read_data(prec%athres,psb_inp_unit) ! smoother aggr thresh + call read_data(prec%ascale,psb_inp_unit) ! smoother aggr thresh end if end if @@ -441,7 +451,6 @@ contains call psb_bcast(icontxt,itrace) call psb_bcast(icontxt,irst) call psb_bcast(icontxt,eps) - call psb_bcast(icontxt,prec%descr) ! verbose description of the prec call psb_bcast(icontxt,prec%prec) ! overall prectype call psb_bcast(icontxt,prec%novr) ! number of overlap layers @@ -456,6 +465,7 @@ contains call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%aggr_ord) ! Ordering for aggregation call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing call psb_bcast(icontxt,prec%cmat) ! coarse mat @@ -465,6 +475,7 @@ contains call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. ILU(T) call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh + call psb_bcast(icontxt,prec%ascale) ! smoother aggr scale factor end if end subroutine get_parms diff --git a/tests/fileread/df_sample.f90 b/tests/fileread/df_sample.f90 index ee732223..713a64c0 100644 --- a/tests/fileread/df_sample.f90 +++ b/tests/fileread/df_sample.f90 @@ -62,6 +62,7 @@ program df_sample integer(psb_ipk_) :: nlev ! number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed, raw aggregation character(len=16) :: aggr_alg ! aggregation algorithm (currently only decoupled) + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative multi-level prec character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: cmat ! coarse mat: distributed, replicated @@ -104,12 +105,12 @@ program df_sample character(len=40) :: fprefix ! other variables - integer(psb_ipk_) :: i,info,j,m_problem, lbw,ubw,prf - integer(psb_ipk_) :: internal, m,ii,nnzero - real(psb_dpk_) :: t1, t2, tprec - real(psb_dpk_) :: r_amax, b_amax, scale,resmx,resmxp - integer(psb_ipk_) :: nrhs, nrow, n_row, dim, nv, ne - integer(psb_ipk_), allocatable :: ivg(:), ipv(:),perm(:) + integer(psb_ipk_) :: i,info,j,m_problem + integer(psb_ipk_) :: internal, m,ii,nnzero + real(psb_dpk_) :: t1, t2, tprec + real(psb_dpk_) :: r_amax, b_amax, scale,resmx,resmxp + integer(psb_ipk_) :: nrhs, nrow, n_row, dim, nv, ne + integer(psb_ipk_), allocatable :: ivg(:), ipv(:) call psb_init(ictxt) call psb_info(ictxt,iam,np) @@ -125,7 +126,6 @@ program df_sample if(psb_get_errstatus() /= 0) goto 9999 info=psb_success_ call psb_set_errverbosity(itwo) - call psb_cd_set_large_threshold(itwo) ! ! Hello world ! @@ -192,6 +192,7 @@ program df_sample b_col_glob(i) = 1.d0 enddo endif + call psb_bcast(ictxt,b_col_glob(1:m_problem)) else call psb_bcast(ictxt,m_problem) call psb_realloc(m_problem,1,aux_b,ircode) @@ -200,35 +201,9 @@ program df_sample goto 9999 endif b_col_glob =>aux_b(:,1) + call psb_bcast(ictxt,b_col_glob(1:m_problem)) end if - ! - ! Renumbering? - ! - if (iam==psb_root_) then - renum='NONE' - call psb_cmp_bwpf(aux_a,lbw,ubw,prf,info) - write(*,*) 'Bandwidth and profile (original): ',lbw,ubw,prf - write(*,*) 'Renumbering algorithm : ',psb_toupper(renum) - if (trim(psb_toupper(renum))/='NONE') then - call psb_mat_renum(renum,aux_a,info,perm=perm) - if (info /= 0) then - write(0,*) 'Error from RENUM',info - goto 9999 - end if - - call psb_gelp('N',perm(1:m_problem),& - & b_col_glob(1:m_problem),info) - call psb_cmp_bwpf(aux_a,lbw,ubw,prf,info) - end if - - write(*,*) 'Bandwidth and profile (renumbrd):',lbw,ubw,prf - end if - - call psb_bcast(ictxt,b_col_glob(1:m_problem)) - - call aux_a%clean_zeros(info) - ! switch over different partition types if (ipart == 0) then call psb_barrier(ictxt) @@ -281,31 +256,27 @@ program df_sample if (psb_toupper(prec_choice%prec) == 'ML') then nlv = prec_choice%nlev call mld_precinit(prec,prec_choice%prec,info,nlev=nlv) - call mld_precset(prec,mld_smoother_type_, prec_choice%smther, info) call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) + call mld_precset(prec,mld_aggr_ord_, prec_choice%aggr_ord,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) call mld_precset(prec,mld_smoother_pos_, prec_choice%smthpos, info) call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) - call mld_precset(prec,mld_ml_type_,'MULT',info) - call mld_precset(prec,mld_smoother_pos_,'TWOSIDE',info) - call mld_precset(prec,mld_coarse_sweeps_,4,info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) call mld_precset(prec,mld_coarse_mat_, prec_choice%cmat, info) call mld_precset(prec,mld_coarse_fillin_, prec_choice%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prec_choice%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prec_choice%cjswp, info) - else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) @@ -335,11 +306,6 @@ program df_sample write(psb_out_unit,'(" ")') end if - write(fprefix,'(a,i3.3,a,i3.3)') 'proc-',iam,'-',np - call prec%dump(info,head='Pressure test case',ac=.true.) - - - iparm = 0 call psb_barrier(ictxt) t1 = psb_wtime() @@ -414,7 +380,6 @@ program df_sample 9999 continue call psb_error(ictxt) - contains ! ! get iteration parameters from standard input @@ -461,6 +426,7 @@ contains call read_data(prec%smther,psb_inp_unit) ! Smoother type. call read_data(prec%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prec%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prec%aggr_ord,psb_inp_unit) ! Ordering for aggregation call read_data(prec%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prec%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prec%cmat,psb_inp_unit) ! coarse mat @@ -499,6 +465,7 @@ contains call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%aggr_ord) ! Ordering for aggregation call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing call psb_bcast(icontxt,prec%cmat) ! coarse mat diff --git a/tests/fileread/runs/cfs.inp b/tests/fileread/runs/cfs.inp index e413b615..2e446cf2 100644 --- a/tests/fileread/runs/cfs.inp +++ b/tests/fileread/runs/cfs.inp @@ -10,24 +10,26 @@ CSR ! Storage format: CSR COO JAD 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-5 ! EPS 3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) -ML ! Preconditioner type: NONE DIAG BJAC AS ML +ML ! Preconditioner type: NONE JACOBI BJAC AS ML 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: ILU MILU ILUT UMF SLU MUMPS +ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS 1 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) -1 ! Jacobi sweeps +1 ! Jacobi sweeps for base smoother 3 ! Number of levels in a multilevel preconditioner AS ! Smoother type JACOBI BJAC AS ignored for non-ML -SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED MINENERGY +SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT POST ! Side of multiplicative correction PRE POST TWOSIDE (ignored for ADD) -DIST ! Coarsest-level matrix distribution: DIST REPL -BJAC ! Coarsest-level solver: BJAC UMF SLU SLUDIST MUMPS -ILU ! Coarsest-level subsolver: ILU UMF SLU SLUDIST MUMPS +REPL ! Coarsest-level matrix distribution: DIST REPL +BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU SLUDIST MUMPS +ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) 0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) -4 ! Number of Jacobi sweeps for BJAC coarsest-level solver -0.10d0 ! Smoothed aggregation threshold: >= 0.0 +4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver +0.0125d0 ! Smoothed aggregation threshold: >= 0.0 +0.5 ! Smoothed aggregation scaling factor. diff --git a/tests/fileread/runs/dfs.inp b/tests/fileread/runs/dfs.inp index 31255d23..e711e051 100644 --- a/tests/fileread/runs/dfs.inp +++ b/tests/fileread/runs/dfs.inp @@ -1,34 +1,35 @@ -pressmat.mtx ! This matrix (and others) from: http://math.nist.gov/MatrixMarket/ or -pressrhs.mtx ! rhs | http://www.cise.ufl.edu/research/sparse/matrices/index.html +DATIAMBRA/matrix.mm ! This matrix (and others) from: http://math.nist.gov/MatrixMarket/ or +DATIAMBRA/rhs.mm ! rhs | http://www.cise.ufl.edu/research/sparse/matrices/index.html MM ! -RGMRES ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format: CSR COO JAD 0 ! IPART (partition method): 0 (block) 2 (graph, with Metis) 2 ! ISTOPC -01000 ! ITMAX -02 ! ITRACE +00100 ! ITMAX +01 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) -1.d-9 ! EPS +1.d-6 ! EPS 4L-M-RAS-I-UR ! Longer descriptive name for preconditioner (up to 20 chars) ML ! Preconditioner type: NONE JACOBI BJAC AS ML -1 ! Number of overlap layers for AS preconditioner +0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS +GS ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS 0 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) -1 ! Number of Jacobi sweeps for base smoother +4 ! Number of Jacobi sweeps for base smoother 4 ! Number of levels in a multilevel preconditioner -AS ! Smoother type JACOBI BJAC AS ignored for non-ML +BJAC ! Smoother type JACOBI BJAC AS ignored for non-ML SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT -TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) -DIST ! Coarsest-level matrix distribution: DIST REPL -BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU MUMPS SLUDIST +POST ! Side of multiplicative correction PRE POST TWOSIDE (ignored for ADD) +REPL ! Coarsest-level matrix distribution: DIST REPL +BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU SLUDIST MUMPS ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) -1 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) +0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) -2 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver +4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver 0.0125d0 ! Smoothed aggregation threshold: >= 0.0 0.5 ! Smoothed aggregation scaling factor. diff --git a/tests/fileread/runs/sfs.inp b/tests/fileread/runs/sfs.inp index e879010f..9dbe7aab 100644 --- a/tests/fileread/runs/sfs.inp +++ b/tests/fileread/runs/sfs.inp @@ -10,24 +10,26 @@ CSR ! Storage format: CSR COO JAD 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-5 ! EPS 3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) -ML ! Preconditioner type: NONE DIAG BJAC AS ML +ML ! Preconditioner type: NONE JACOBI BJAC AS ML 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: ILU MILU ILUT UMF SLU MUMPS +ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS 1 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) -1 ! Jacobi sweeps -3 ! Number of levels in a multilevel preconditioner -AS ! Smoother type JACOBI BJAC AS ignored for non-ML -SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED MINENERGY +4 ! Number of Jacobi sweeps for base smoother +4 ! Number of levels in a multilevel preconditioner +BJAC ! Smoother type JACOBI BJAC AS ignored for non-ML +SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT POST ! Side of multiplicative correction PRE POST TWOSIDE (ignored for ADD) -DIST ! Coarsest-level matrix distribution: DIST REPL -BJAC ! Coarsest-level solver: BJAC UMF SLU SLUDIST MUMPS -ILU ! Coarsest-level subsolver: ILU UMF SLU SLUDIST MUMPS +REPL ! Coarsest-level matrix distribution: DIST REPL +BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU SLUDIST MUMPS +ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) 0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) -4 ! Number of Jacobi sweeps for BJAC coarsest-level solver -0.10d0 ! Smoothed aggregation threshold: >= 0.0 +4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver +0.0125d0 ! Smoothed aggregation threshold: >= 0.0 +0.5 ! Smoothed aggregation scaling factor. diff --git a/tests/fileread/runs/zfs.inp b/tests/fileread/runs/zfs.inp index 0fbb30de..3abbed35 100644 --- a/tests/fileread/runs/zfs.inp +++ b/tests/fileread/runs/zfs.inp @@ -14,20 +14,22 @@ ML ! Preconditioner type: NONE JACOBI BJAC AS ML 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: ILU MILU ILUT UMF SLU MUMPS +ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS 1 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) 4 ! Number of Jacobi sweeps for base smoother -3 ! Number of levels in a multilevel preconditioner -AS ! Smoother type JACOBI BJAC AS ignored for non-ML -SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED MINENERGY +4 ! Number of levels in a multilevel preconditioner +BJAC ! Smoother type JACOBI BJAC AS ignored for non-ML +SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT POST ! Side of multiplicative correction PRE POST TWOSIDE (ignored for ADD) REPL ! Coarsest-level matrix distribution: DIST REPL BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU SLUDIST MUMPS -UMF ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) +ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) 0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) -4 ! Number of Jacobi sweeps for BJAC coarsest-level solver -0.10d0 ! Smoothed aggregation threshold: >= 0.0 +4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver +0.0125d0 ! Smoothed aggregation threshold: >= 0.0 +0.5 ! Smoothed aggregation scaling factor. diff --git a/tests/fileread/sf_sample.f90 b/tests/fileread/sf_sample.f90 index eea679c7..e3a0e946 100644 --- a/tests/fileread/sf_sample.f90 +++ b/tests/fileread/sf_sample.f90 @@ -62,6 +62,7 @@ program sf_sample integer(psb_ipk_) :: nlev ! number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed, raw aggregation character(len=16) :: aggr_alg ! aggregation algorithm (currently only decoupled) + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative multi-level prec character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: cmat ! coarse mat: distributed, replicated @@ -71,6 +72,7 @@ program sf_sample real(psb_spk_) :: cthres ! threshold for coarse fact. ILU(T) integer(psb_ipk_) :: cjswp ! block-Jacobi sweeps real(psb_spk_) :: athres ! smoothed aggregation threshold + real(psb_spk_) :: ascale ! smoothed aggregation scale factor end type precdata type(precdata) :: prec_choice @@ -260,12 +262,14 @@ program sf_sample call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) + call mld_precset(prec,mld_aggr_ord_, prec_choice%aggr_ord,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) call mld_precset(prec,mld_smoother_pos_, prec_choice%smthpos, info) + call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) @@ -276,15 +280,16 @@ program sf_sample else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) - call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) - call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) - call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) - call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) - call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + if (psb_toupper(prec_choice%prec) /= 'NONE') then + call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) + call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) + call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) + call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + end if end if - ! building the preconditioner t1 = psb_wtime() call mld_precbld(a,desc_a,prec,info) @@ -336,6 +341,8 @@ program sf_sample write(psb_out_unit,'("Total memory occupation for A : ",i12)')amatsize write(psb_out_unit,'("Total memory occupation for DESC_A : ",i12)')descsize write(psb_out_unit,'("Total memory occupation for PREC : ",i12)')precsize + write(psb_out_unit,'("Storage format for A : ",a )')a%get_fmt() + write(psb_out_unit,'("Storage format for DESC_A : ",a )')desc_a%get_fmt() end if call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) @@ -383,12 +390,12 @@ contains use psb_base_mod implicit none - integer(psb_ipk_) :: icontxt + integer(psb_ipk_) :: icontxt character(len=*) :: kmethd, mtrx, rhs, afmt,filefmt type(precdata) :: prec real(psb_spk_) :: eps - integer(psb_ipk_) :: iret, istopc,itmax,itrace, ipart, irst - integer(psb_ipk_) :: iam, nm, np, i + integer(psb_ipk_) :: iret, istopc,itmax,itrace, ipart, irst + integer(psb_ipk_) :: iam, nm, np, i call psb_info(icontxt,iam,np) @@ -419,15 +426,17 @@ contains call read_data(prec%smther,psb_inp_unit) ! Smoother type. call read_data(prec%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prec%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prec%aggr_ord,psb_inp_unit) ! Ordering for aggregation call read_data(prec%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prec%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prec%cmat,psb_inp_unit) ! coarse mat - call read_data(prec%csolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%csolve,psb_inp_unit) ! Factorization type: BJAC, SuperLU, UMFPACK. call read_data(prec%csbsolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. call read_data(prec%cfill,psb_inp_unit) ! Fill-in for factorization call read_data(prec%cthres,psb_inp_unit) ! Threshold for fact. ILU(T) call read_data(prec%cjswp,psb_inp_unit) ! Jacobi sweeps call read_data(prec%athres,psb_inp_unit) ! smoother aggr thresh + call read_data(prec%ascale,psb_inp_unit) ! smoother aggr thresh end if end if @@ -442,7 +451,6 @@ contains call psb_bcast(icontxt,itrace) call psb_bcast(icontxt,irst) call psb_bcast(icontxt,eps) - call psb_bcast(icontxt,prec%descr) ! verbose description of the prec call psb_bcast(icontxt,prec%prec) ! overall prectype call psb_bcast(icontxt,prec%novr) ! number of overlap layers @@ -457,6 +465,7 @@ contains call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%aggr_ord) ! Ordering for aggregation call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing call psb_bcast(icontxt,prec%cmat) ! coarse mat @@ -466,6 +475,7 @@ contains call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. ILU(T) call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh + call psb_bcast(icontxt,prec%ascale) ! smoother aggr scale factor end if end subroutine get_parms diff --git a/tests/fileread/zf_sample.f90 b/tests/fileread/zf_sample.f90 index 1775e877..981e2d53 100644 --- a/tests/fileread/zf_sample.f90 +++ b/tests/fileread/zf_sample.f90 @@ -62,6 +62,7 @@ program zf_sample integer(psb_ipk_) :: nlev ! number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed, raw aggregation character(len=16) :: aggr_alg ! aggregation algorithm (currently only decoupled) + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative multi-level prec character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: cmat ! coarse mat: distributed, replicated @@ -71,6 +72,7 @@ program zf_sample real(psb_dpk_) :: cthres ! threshold for coarse fact. ILU(T) integer(psb_ipk_) :: cjswp ! block-Jacobi sweeps real(psb_dpk_) :: athres ! smoothed aggregation threshold + real(psb_dpk_) :: ascale ! smoothed aggregation scale factor end type precdata type(precdata) :: prec_choice @@ -260,12 +262,14 @@ program zf_sample call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) + call mld_precset(prec,mld_aggr_ord_, prec_choice%aggr_ord,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) call mld_precset(prec,mld_smoother_pos_, prec_choice%smthpos, info) + call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) @@ -276,15 +280,16 @@ program zf_sample else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) - call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) - call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) - call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) - call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) - call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + if (psb_toupper(prec_choice%prec) /= 'NONE') then + call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) + call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) + call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) + call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + end if end if - ! building the preconditioner t1 = psb_wtime() call mld_precbld(a,desc_a,prec,info) @@ -336,6 +341,8 @@ program zf_sample write(psb_out_unit,'("Total memory occupation for A : ",i12)')amatsize write(psb_out_unit,'("Total memory occupation for DESC_A : ",i12)')descsize write(psb_out_unit,'("Total memory occupation for PREC : ",i12)')precsize + write(psb_out_unit,'("Storage format for A : ",a )')a%get_fmt() + write(psb_out_unit,'("Storage format for DESC_A : ",a )')desc_a%get_fmt() end if call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) @@ -366,6 +373,7 @@ program zf_sample call psb_spfree(a, desc_a,info) call mld_precfree(prec,info) call psb_cdfree(desc_a,info) + call psb_exit(ictxt) stop @@ -382,12 +390,12 @@ contains use psb_base_mod implicit none - integer(psb_ipk_) :: icontxt + integer(psb_ipk_) :: icontxt character(len=*) :: kmethd, mtrx, rhs, afmt,filefmt type(precdata) :: prec real(psb_dpk_) :: eps - integer(psb_ipk_) :: iret, istopc,itmax,itrace, ipart, irst - integer(psb_ipk_) :: iam, nm, np, i + integer(psb_ipk_) :: iret, istopc,itmax,itrace, ipart, irst + integer(psb_ipk_) :: iam, nm, np, i call psb_info(icontxt,iam,np) @@ -418,15 +426,17 @@ contains call read_data(prec%smther,psb_inp_unit) ! Smoother type. call read_data(prec%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prec%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prec%aggr_ord,psb_inp_unit) ! Ordering for aggregation call read_data(prec%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prec%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prec%cmat,psb_inp_unit) ! coarse mat - call read_data(prec%csolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%csolve,psb_inp_unit) ! Factorization type: BJAC, SuperLU, UMFPACK. call read_data(prec%csbsolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. call read_data(prec%cfill,psb_inp_unit) ! Fill-in for factorization call read_data(prec%cthres,psb_inp_unit) ! Threshold for fact. ILU(T) call read_data(prec%cjswp,psb_inp_unit) ! Jacobi sweeps call read_data(prec%athres,psb_inp_unit) ! smoother aggr thresh + call read_data(prec%ascale,psb_inp_unit) ! smoother aggr thresh end if end if @@ -441,7 +451,6 @@ contains call psb_bcast(icontxt,itrace) call psb_bcast(icontxt,irst) call psb_bcast(icontxt,eps) - call psb_bcast(icontxt,prec%descr) ! verbose description of the prec call psb_bcast(icontxt,prec%prec) ! overall prectype call psb_bcast(icontxt,prec%novr) ! number of overlap layers @@ -456,6 +465,7 @@ contains call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%aggr_ord) ! Ordering for aggregation call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing call psb_bcast(icontxt,prec%cmat) ! coarse mat @@ -465,6 +475,7 @@ contains call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. ILU(T) call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh + call psb_bcast(icontxt,prec%ascale) ! smoother aggr scale factor end if end subroutine get_parms diff --git a/tests/pdegen/Makefile b/tests/pdegen/Makefile index 7bbe3439..66a0b906 100644 --- a/tests/pdegen/Makefile +++ b/tests/pdegen/Makefile @@ -11,12 +11,16 @@ FINCLUDES=$(FMFLAG). $(FMFLAG)$(MLDINCDIR) $(FMFLAG)$(PSBINCDIR) $(FIFLAG). EXEDIR=./runs -all: spde3d ppde3d spde2d ppde2d +all: spde3d ppde3d spde2d ppde2d ppde3d-gs ppde3d: ppde3d.o data_input.o $(F90LINK) ppde3d.o data_input.o -o ppde3d $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv ppde3d $(EXEDIR) +ppde3d-gs: ppde3d-gs.o data_input.o + $(F90LINK) ppde3d-gs.o data_input.o -o ppde3d-gs $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) + /bin/mv ppde3d-gs $(EXEDIR) + spde3d: spde3d.o data_input.o $(F90LINK) spde3d.o data_input.o -o spde3d $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv spde3d $(EXEDIR) @@ -30,15 +34,15 @@ spde2d: spde2d.o data_input.o $(F90LINK) spde2d.o data_input.o -o spde2d $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv spde2d $(EXEDIR) -ppde3d.o spde3d.o ppde2d.o spde2d.o: data_input.o +ppde3d-gs.o ppde3d.o spde3d.o ppde2d.o spde2d.o: data_input.o check: all cd runs && ./ppde2d = dzero) & + & call mld_precset(prec,'aggr_thresh', prectype%athres, info) + call mld_precset(prec,'coarse_solve', prectype%csolve, info) + call mld_precset(prec,'coarse_subsolve', prectype%csbsolve,info) + call mld_precset(prec,'coarse_mat', prectype%cmat, info) + call mld_precset(prec,'coarse_fillin', prectype%cfill, info) + call mld_precset(prec,'coarse_iluthrs', prectype%cthres, info) + call mld_precset(prec,'coarse_sweeps', prectype%cjswp, info) + call mld_precset(prec,'coarse_aggr_size', prectype%csize, info) + call prec%set(dbsmth,info,pos='post') + call prec%set(dbwgs,info,pos='post') + call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info, pos='post') + else + nlv = 1 + call mld_precinit(prec,prectype%prec, info, nlev=nlv) + call mld_precset(prec,'smoother_sweeps', prectype%jsweeps, info) + call mld_precset(prec,'sub_ovr', prectype%novr, info) + call mld_precset(prec,'sub_restr', prectype%restr, info) + call mld_precset(prec,'sub_prol', prectype%prol, info) + call mld_precset(prec,'sub_solve', prectype%solve, info) + call mld_precset(prec,'sub_fillin', prectype%fill1, info) + call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info) + call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) + call prec%set(dbsmth,info,pos='post') + call prec%set(dbwgs,info,pos='post') + call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info, pos='post') + 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 prec%dump(info,prefix='test-ml',ac=.true.,solver=.true.,smoother=.true.) + + call psb_amx(ictxt,tprec) + + if (iam == psb_root_) & + & write(psb_out_unit,'("Preconditioner time : ",es12.5)')tprec + if (iam == psb_root_) call mld_precdescr(prec,info) + if (iam == psb_root_) & + & write(psb_out_unit,'(" ")') + + ! + ! iterative method parameters + ! + if(iam == psb_root_) & + & write(psb_out_unit,'("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 = a%sizeof() + descsize = desc_a%sizeof() + precsize = prec%sizeof() + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam == psb_root_) then + write(psb_out_unit,'(" ")') + write(psb_out_unit,'("Time to solve matrix : ",es12.5)') t2 + write(psb_out_unit,'("Time per iteration : ",es12.5)') t2/iter + write(psb_out_unit,'("Number of iterations : ",i0)') iter + write(psb_out_unit,'("Convergence indicator on exit : ",es12.5)') err + write(psb_out_unit,'("Info on exit : ",i0)') info + write(psb_out_unit,'("Total memory occupation for A: ",i12)') amatsize + write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)') descsize + write(psb_out_unit,'("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 + call psb_exit(ictxt) + stop + +9999 continue + call psb_error(ictxt) + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + integer(psb_ipk_) :: ictxt + type(precdata) :: prectype + character(len=*) :: kmethd, afmt + integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst + integer(psb_ipk_) :: 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,psb_inp_unit) + call read_data(afmt,psb_inp_unit) + call read_data(idim,psb_inp_unit) + call read_data(istopc,psb_inp_unit) + call read_data(itmax,psb_inp_unit) + call read_data(itrace,psb_inp_unit) + call read_data(irst,psb_inp_unit) + call read_data(eps,psb_inp_unit) + call read_data(prectype%descr,psb_inp_unit) ! verbose description of the prec + call read_data(prectype%prec,psb_inp_unit) ! overall prectype + call read_data(prectype%novr,psb_inp_unit) ! number of overlap layers + call read_data(prectype%restr,psb_inp_unit) ! restriction over application of as + call read_data(prectype%prol,psb_inp_unit) ! prolongation over application of as + call read_data(prectype%solve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%svsweeps,psb_inp_unit) ! Solver sweeps + call read_data(prectype%fill1,psb_inp_unit) ! Fill-in for factorization 1 + call read_data(prectype%thr1,psb_inp_unit) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%jsweeps,psb_inp_unit) ! Jacobi sweeps for PJAC + if (psb_toupper(prectype%prec) == 'ML') then + call read_data(prectype%smther,psb_inp_unit) ! Smoother type. + call read_data(prectype%nlev,psb_inp_unit) ! Number of levels in multilevel prec. + call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin + call read_data(prectype%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prectype%aggr_ord,psb_inp_unit) ! aggregation ordering + call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec + call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing + call read_data(prectype%cmat,psb_inp_unit) ! coarse mat + call read_data(prectype%csolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%csbsolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%cfill,psb_inp_unit) ! Fill-in for factorization 1 + call read_data(prectype%cthres,psb_inp_unit) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%cjswp,psb_inp_unit) ! Jacobi sweeps + call read_data(prectype%athres,psb_inp_unit) ! smoother aggr thresh + call read_data(prectype%csize,psb_inp_unit) ! coarse size + 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%svsweeps) ! Sweeps for inner GS solver + 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%aggr_ord) ! aggregation ordering + 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 + call psb_bcast(ictxt,prectype%csize) ! coarse size + end if + + if (iam == psb_root_) then + write(psb_out_unit,'("Solving matrix : ell1")') + write(psb_out_unit,'("Grid dimensions : ",i4,"x",i4,"x",i4)')idim,idim,idim + write(psb_out_unit,'("Number of processors : ",i0)') np + write(psb_out_unit,'("Data distribution : BLOCK")') + write(psb_out_unit,'("Preconditioner : ",a)') prectype%descr + write(psb_out_unit,'("Iterative method : ",a)') kmethd + write(psb_out_unit,'(" ")') + endif + + return + + end subroutine get_parms + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer(psb_ipk_) :: 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 + +end program ppde3d + diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index c77e56c6..47b6324d 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,31 +1,31 @@ -RGMRES ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD 0100 ! IDIM; domain size is idim**3 2 ! ISTOPC -0100 ! ITMAX +2000 ! ITMAX 10 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS 3L-MUL-RAS-BJAC4-ILU ! Descriptive name for preconditioner (up to 40 chars) ML ! Preconditioner NONE JACOBI BJAC AS ML -1 ! Number of overlap layers for AS preconditioner at finest level +0 ! Number of overlap layers for AS preconditioner at finest level HALO ! Restriction operator NONE HALO NONE ! Prolongation operator NONE SUM AVG GS ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU -1 ! sweeps for GS +4 ! Solver sweeps for GS 0 ! Level-set N for ILU(N), and P for ILUT 1.d-4 ! Threshold T for ILU(T,P) -1 ! Smoother/Jacobi sweeps +4 ! Smoother/Jacobi sweeps BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML 2 ! Number of levels in a multilevel preconditioner SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED, MINENERGY DEC ! Type of aggregation DEC SYMDEC GLB -DEGREE ! Ordering of aggregation NATURAL DEGREE +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) -REPL ! Coarse level: matrix distribution DIST REPL +DIST ! Coarse level: matrix distribution DIST REPL BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST MUMPS -MUMPS ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST MUMPS +ILU ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST MUMPS 1 ! Coarse level: Level-set N for ILU(N) 1.d-4 ! Coarse level: Threshold T for ILU(T,P) 4 ! Coarse level: Number of Jacobi sweeps