fdurastante
/
amg4psblas
mirror of https://github.com/sfilippone/amg4psblas.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

mld2p4-smooth-2side:

Browse Source 
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.
stopcriterion
Salvatore Filippone 9 years ago
parent e04303e77b
commit df01dcfebd
5 changed files with 329 additions and 1079 deletions
Show Stats Download Patch File Download Diff File

111
mlprec/impl/level/mld_d_base_onelev_cseti.F90
Unescape Escape View File

@ -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

137
mlprec/impl/level/mld_d_base_onelev_seti.F90
Unescape Escape View File

@ -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

509
mlprec/impl/mld_dcprecset.F90
Unescape Escape View File

@ -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
!

649
mlprec/impl/mld_dprecset.F90
Unescape Escape View File

@ -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

2
tests/pdegen/runs/ppde.inp
Unescape Escape View File

@ -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

Write Preview
Loading…
Cancel
Save