From df01dcfebd3c5cb5ffb4af383ab62703772ce881 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 13 May 2016 16:30:26 +0000 Subject: [PATCH] mld2p4-smooth-2side: mlprec/impl/level/mld_d_base_onelev_cseti.F90 mlprec/impl/level/mld_d_base_onelev_seti.F90 mlprec/impl/mld_dcprecset.F90 mlprec/impl/mld_dprecset.F90 tests/pdegen/runs/ppde.inp Done refactoring of SM and SV in SETI. --- mlprec/impl/level/mld_d_base_onelev_cseti.F90 | 111 ++- mlprec/impl/level/mld_d_base_onelev_seti.F90 | 137 +++- mlprec/impl/mld_dcprecset.F90 | 509 ++------------ mlprec/impl/mld_dprecset.F90 | 649 ++---------------- tests/pdegen/runs/ppde.inp | 2 +- 5 files changed, 329 insertions(+), 1079 deletions(-) diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 index d23edb64..9e28388f 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 @@ -40,6 +40,24 @@ 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 @@ -52,7 +70,26 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,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 +#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_ @@ -70,6 +107,78 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) 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_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 diff --git a/mlprec/impl/level/mld_d_base_onelev_seti.F90 b/mlprec/impl/level/mld_d_base_onelev_seti.F90 index e181b8f0..f60432b0 100644 --- a/mlprec/impl/level/mld_d_base_onelev_seti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_seti.F90 @@ -40,6 +40,24 @@ 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 @@ -52,12 +70,115 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,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 +#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_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 @@ -101,18 +222,6 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) case default - 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 diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 825220ff..191c655b 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -150,31 +150,13 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) ! ! 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,pos=pos) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - 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,pos=pos) - - case default - call p%precv(ilev_)%set(what,val,info,pos=pos) - 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,pos=pos) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - 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',& @@ -190,7 +172,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) + 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 +180,36 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) info = -2 return end if - + if (nlev_ > 1) then 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,pos=pos) + 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,pos=pos) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) + 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,pos=pos) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) + 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,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,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + 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_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,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,pos=pos) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + 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 @@ -250,6 +228,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) return end if call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default call p%precv(ilev_)%set(what,val,info,pos=pos) end select @@ -262,33 +241,12 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') - 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,pos=pos) - - 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,pos=pos) - end do - - case('SMOOTHER_SWEEPS') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) call p%precv(ilev_)%set(what,val,info,pos=pos) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -297,6 +255,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') @@ -305,45 +264,40 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) end if case('COARSE_SOLVE') - if (nlev_ > 1) then + if (nlev_ > 1) then 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,pos=pos) + 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,pos=pos) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) + 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,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,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + 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_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,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_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),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,pos=pos) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + 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,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') @@ -356,6 +310,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) if (nlev_ > 1) then 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,pos=pos) @@ -364,382 +319,6 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) endif -contains - - subroutine onelev_set_smoother(level,val,info,pos) - class(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local - integer(psb_ipk_) :: ipos_ - 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_) - call inner_set_smoother(level%sm,val,info) - case (mld_post_smooth_) - call inner_set_smoother(level%sm2a,val,info) - case default - ! Impossible!! - info = psb_err_internal_error_ - end select - end subroutine onelev_set_smoother - - - subroutine inner_set_smoother(sm,val,info) - class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(sm)) then - select type (sms => sm) - type is (mld_d_base_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_base_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_base_smoother_type ::& - & sm, stat=info) - if (info ==0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_jac_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_jac_smoother_type :: & - & sm, stat=info) - if (info == 0) allocate(mld_d_diag_solver_type :: & - & sm%sv, stat=info) - end select - else - allocate(mld_d_jac_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_jac_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_jac_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_jac_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_as_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_as_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_as_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(sm)) & - & call sm%default() - end subroutine inner_set_smoother - - - subroutine onelev_set_solver(level,val,info,pos) - class(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local - integer(psb_ipk_) :: ipos_ - 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_) - call inner_set_solver(level%sm,val,info) - case (mld_post_smooth_) - call inner_set_solver(level%sm2a,val,info) - case default - ! Impossible!! - info = psb_err_internal_error_ - end select - - end subroutine onelev_set_solver - - - subroutine inner_set_solver(sm,val,info) - class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - ! - ! Yes, the first argument is a smoother, to catch the case where - ! user is trying to set a solver on a not-yet-allocated smoother. - ! - select case (val) - case (mld_f_none_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_id_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_id_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_diag_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_diag_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_gs_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_gs_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_gs_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm%sv)) then - call 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(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_ilu_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_ilu_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - call 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(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_slu_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_slu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_slu_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call 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(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_mumps_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_mumps_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_mumps_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if -#endif - -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_umf_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_umf_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_umf_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call 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(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_sludist_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_sludist_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call 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 inner_set_solver - end subroutine mld_dcprecseti ! diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index cc51826b..c11ba37d 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -148,34 +148,16 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) 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,pos=pos) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - 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,pos=pos) - case default - call p%precv(ilev_)%set(what,val,info,pos=pos) - 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,pos=pos) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - 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_,& @@ -189,7 +171,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) + 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,& @@ -202,28 +184,28 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) 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,pos=pos) + 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,pos=pos) + 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,pos=pos) + 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,pos=pos) + 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,pos=pos) + 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,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,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + 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,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + 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,pos=pos) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + 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 @@ -257,33 +239,12 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) ! levels ! select case(what) - case(mld_sub_solve_) - 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,pos=pos) - - 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,pos=pos) - end do - - case(mld_smoother_sweeps_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info,pos=pos) - end do - - case(mld_smoother_type_) + 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) - call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) + call p%precv(ilev_)%set(mld_smoother_type_,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -305,30 +266,30 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) 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,pos=pos) + 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,pos=pos) + 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,pos=pos) + 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,pos=pos) + 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,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,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + 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,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + 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,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + 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,pos=pos) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + 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 @@ -336,7 +297,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) @@ -357,382 +318,6 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) endif -contains - - subroutine onelev_set_smoother(level,val,info,pos) - class(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local - integer(psb_ipk_) :: ipos_ - 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_) - call inner_set_smoother(level%sm,val,info) - case (mld_post_smooth_) - call inner_set_smoother(level%sm2a,val,info) - case default - ! Impossible!! - info = psb_err_internal_error_ - end select - end subroutine onelev_set_smoother - - - subroutine inner_set_smoother(sm,val,info) - class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(sm)) then - select type (sms => sm) - type is (mld_d_base_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_base_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_base_smoother_type ::& - & sm, stat=info) - if (info ==0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_jac_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_jac_smoother_type :: & - & sm, stat=info) - if (info == 0) allocate(mld_d_diag_solver_type :: & - & sm%sv, stat=info) - end select - else - allocate(mld_d_jac_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_jac_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_jac_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_jac_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_as_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_as_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_as_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(sm)) & - & call sm%default() - end subroutine inner_set_smoother - - - subroutine onelev_set_solver(level,val,info,pos) - class(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local - integer(psb_ipk_) :: ipos_ - 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_) - call inner_set_solver(level%sm,val,info) - case (mld_post_smooth_) - call inner_set_solver(level%sm2a,val,info) - case default - ! Impossible!! - info = psb_err_internal_error_ - end select - - end subroutine onelev_set_solver - - - subroutine inner_set_solver(sm,val,info) - class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - ! - ! Yes, the first argument is a smoother, to catch the case where - ! user is trying to set a solver on a not-yet-allocated smoother. - ! - select case (val) - case (mld_f_none_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_id_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_id_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_diag_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_diag_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_gs_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_gs_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_gs_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm%sv)) then - call 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(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_ilu_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_ilu_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - call 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(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_slu_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_slu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_slu_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call 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(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_mumps_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_mumps_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_mumps_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if -#endif - -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_umf_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_umf_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_umf_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call 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(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_sludist_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_sludist_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call 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 inner_set_solver - end subroutine mld_dprecseti subroutine mld_dprecsetsm(p,val,info,ilev,pos) @@ -750,7 +335,7 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos) character(len=*), optional, intent(in) :: pos ! Local variables - integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax, ipos_ + integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -773,64 +358,18 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos) ilmin = 1 ilmax = nlev_ end if - 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 - + if ((ilev_<1).or.(ilev_ > nlev_)) then info = -1 write(psb_err_unit,*) name,& & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ return endif - - select case(ipos_) - case(mld_pre_smooth_) - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (.not.same_type_as(p%precv(ilev_)%sm,val)) then - call p%precv(ilev_)%sm%free(info) - deallocate(p%precv(ilev_)%sm, stat=info) - end if - endif - if (.not.allocated(p%precv(ilev_)%sm)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm,mold=val) -#else - allocate(p%precv(ilev_)%sm,source=val) -#endif - end if - call p%precv(ilev_)%sm%default() - p%precv(ilev_)%sm2 => p%precv(ilev_)%sm - end do - case(mld_post_smooth_) - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm2a)) then - if (.not.same_type_as(p%precv(ilev_)%sm2a,val)) then - call p%precv(ilev_)%sm2a%free(info) - deallocate(p%precv(ilev_)%sm2a, stat=info) - endif - end if - if (.not.allocated(p%precv(ilev_)%sm2a)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm2a,mold=val) -#else - allocate(p%precv(ilev_)%sm2a,source=val) -#endif - end if - call p%precv(ilev_)%sm2a%default() - p%precv(ilev_)%sm2 => p%precv(ilev_)%sm2a - end do - end select + + do ilev_ = ilmin, ilmax + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return + end do end subroutine mld_dprecsetsm @@ -843,13 +382,13 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) ! Arguments class(mld_dprec_type), intent(inout) :: p - 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 + 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, ipos_ + integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -872,19 +411,6 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) ilmin = 1 ilmax = nlev_ end if - - 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 if ((ilev_<1).or.(ilev_ > nlev_)) then @@ -894,83 +420,10 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) return endif - - select case(ipos_) - case(mld_pre_smooth_) - 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 - call p%precv(ilev_)%sm%sv%free(info) - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - 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 - 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 - - end do - - case(mld_post_smooth_) - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm2a)) then - if (allocated(p%precv(ilev_)%sm2a%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm2a%sv,val)) then - call p%precv(ilev_)%sm2a%sv%free(info) - deallocate(p%precv(ilev_)%sm2a%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - end if - if (.not.allocated(p%precv(ilev_)%sm2a%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm2a%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm2a%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - call p%precv(ilev_)%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 do - end select - + do ilev_ = ilmin, ilmax + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return + end do end subroutine mld_dprecsetsv diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index d8baa766..8282eec6 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,4 +1,4 @@ -CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD 0030 ! IDIM; domain size is idim**3 2 ! ISTOPC