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

109
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 psb_base_mod
use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_cseti 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 Implicit None
@ -52,6 +70,25 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
! Local ! Local
integer(psb_ipk_) :: ipos_, err_act integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='d_base_onelev_cseti' 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) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
@ -70,6 +107,78 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
end if end if
select case (psb_toupper(what)) 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') case ('SMOOTHER_SWEEPS')
lv%parms%sweeps = val lv%parms%sweeps = val

133
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 psb_base_mod
use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_seti 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 Implicit None
@ -52,12 +70,115 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
! Local ! Local
integer(psb_ipk_) :: ipos_, err_act integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='d_base_onelev_seti' 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) call psb_erractionsave(err_act)
info = psb_success_ 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) 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_) case (mld_smoother_sweeps_)
lv%parms%sweeps = val lv%parms%sweeps = val
lv%parms%sweeps_pre = val lv%parms%sweeps_pre = val
@ -101,18 +222,6 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
case default 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_) select case(ipos_)
case(mld_pre_smooth_) case(mld_pre_smooth_)
if (allocated(lv%sm)) then if (allocated(lv%sm)) then

495
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. ! Rules for fine level are slightly different.
! !
select case(psb_toupper(trim(what))) call p%precv(ilev_)%set(what,val,info,pos=pos)
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
else if (ilev_ > 1) then else if (ilev_ > 1) then
select case(psb_toupper(what)) select case(psb_toupper(what))
case('SMOOTHER_TYPE') case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) & 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
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_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',& & 'SMOOTHER_SWEEPS_POST',&
@ -190,7 +172,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
info = -2 info = -2
return return
end if 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') case('COARSE_SOLVE')
if (ilev_ /= nlev_) then if (ilev_ /= nlev_) then
write(psb_err_unit,*) name,& write(psb_err_unit,*) name,&
@ -203,32 +185,28 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val) select case (val)
case(mld_bjac_) 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_) #if defined(HAVE_UMF_)
call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
#elif defined(HAVE_SLU_) #elif defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_) #elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
#else #else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif #endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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_) 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 p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call onelev_set_solver(p%precv(nlev_),val,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) call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_) case(mld_sludist_,mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call onelev_set_solver(p%precv(nlev_),val,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) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_jac_) case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,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) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
end select end select
@ -250,6 +228,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
return return
end if end if
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
case default case default
call p%precv(ilev_)%set(what,val,info,pos=pos) call p%precv(ilev_)%set(what,val,info,pos=pos)
end select end select
@ -262,33 +241,12 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
! levels ! levels
! !
select case(psb_toupper(trim(what))) select case(psb_toupper(trim(what)))
case('SUB_SOLVE') case('SUB_SOLVE','SUB_RESTR','SUB_PROL',&
do ilev_=1,max(1,nlev_-1) & 'SUB_REN','SUB_OVR','SUB_FILLIN',&
if (.not.allocated(p%precv(ilev_)%sm)) then & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE')
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')
do ilev_=1,max(1,nlev_-1) do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info,pos=pos) call p%precv(ilev_)%set(what,val,info,pos=pos)
end do if (info /= 0) return
case('SMOOTHER_TYPE')
do ilev_=1,max(1,nlev_-1)
call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos)
end do end do
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& 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') & 'AGGR_EIG','AGGR_FILTER')
do ilev_=1,nlev_ do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos) call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do end do
case('COARSE_MAT') case('COARSE_MAT')
@ -305,45 +264,40 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
end if end if
case('COARSE_SOLVE') case('COARSE_SOLVE')
if (nlev_ > 1) then
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val) select case (val)
case(mld_bjac_) 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_) #if defined(HAVE_UMF_)
call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
#elif defined(HAVE_SLU_) #elif defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_) #elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
#else #else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif #endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) 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_) 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 p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call onelev_set_solver(p%precv(nlev_),val,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) call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_) case(mld_sludist_,mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call onelev_set_solver(p%precv(nlev_),val,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) 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_) case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,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) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
end select end select
endif endif
case('COARSE_SUBSOLVE') case('COARSE_SUBSOLVE')
if (nlev_ > 1) then 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 endif
case('COARSE_SWEEPS') case('COARSE_SWEEPS')
@ -356,6 +310,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
if (nlev_ > 1) then if (nlev_ > 1) then
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
end if end if
case default case default
do ilev_=1,nlev_ do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info,pos=pos) call p%precv(ilev_)%set(what,val,info,pos=pos)
@ -364,382 +319,6 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
endif 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 end subroutine mld_dcprecseti
! !

645
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 (present(ilev)) then
if (ilev_ == 1) 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)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end select
else if (ilev_ > 1) then else if (ilev_ > 1) then
select case(what) select case(what)
case(mld_smoother_type_) case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
case(mld_sub_solve_) & mld_aggr_kind_,mld_smoother_pos_,&
call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) & mld_aggr_omega_alg_,mld_aggr_eig_,&
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_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, & & mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
@ -189,7 +171,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos)
info = -2 info = -2
return return
end if 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_) case(mld_coarse_solve_)
if (ilev_ /= nlev_) then if (ilev_ /= nlev_) then
write(psb_err_unit,*) name,& 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) call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
select case (val) select case (val)
case(mld_bjac_) 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_) #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_) #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_) #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 #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 #endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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_) 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 p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call onelev_set_solver(p%precv(nlev_),val,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) call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_) case(mld_sludist_,mld_mumps_)
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)
call onelev_set_solver(p%precv(nlev_),val,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) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_) case(mld_jac_)
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)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,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) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
end select end select
@ -257,33 +239,12 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos)
! levels ! levels
! !
select case(what) select case(what)
case(mld_sub_solve_) case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
do ilev_=1,max(1,nlev_-1) & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
if (.not.allocated(p%precv(ilev_)%sm)) then & mld_smoother_sweeps_,mld_smoother_type_)
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) do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info,pos=pos) call p%precv(ilev_)%set(mld_smoother_type_,val,info,pos=pos)
end do if (info /= 0) return
case(mld_smoother_type_)
do ilev_=1,max(1,nlev_-1)
call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos)
end do end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& 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) call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
select case (val) select case (val)
case(mld_bjac_) 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_) #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_) #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 #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 #endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) 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_) 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 p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call onelev_set_solver(p%precv(nlev_),val,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) call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_) case(mld_sludist_)
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)
call onelev_set_solver(p%precv(nlev_),val,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) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_mumps_) case(mld_mumps_)
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)
call onelev_set_solver(p%precv(nlev_),val,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) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_) case(mld_jac_)
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)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,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) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
end select end select
@ -336,7 +297,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos)
case(mld_coarse_subsolve_) case(mld_coarse_subsolve_)
if (nlev_ > 1) then 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 endif
case(mld_coarse_sweeps_) case(mld_coarse_sweeps_)
@ -357,382 +318,6 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos)
endif 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 end subroutine mld_dprecseti
subroutine mld_dprecsetsm(p,val,info,ilev,pos) 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 character(len=*), optional, intent(in) :: pos
! Local variables ! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax, ipos_ integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
character(len=*), parameter :: name='mld_precseti' character(len=*), parameter :: name='mld_precseti'
info = psb_success_ info = psb_success_
@ -773,18 +358,6 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos)
ilmin = 1 ilmin = 1
ilmax = nlev_ ilmax = nlev_
end if 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 if ((ilev_<1).or.(ilev_ > nlev_)) then
info = -1 info = -1
@ -793,44 +366,10 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos)
return return
endif endif
select case(ipos_) do ilev_ = ilmin, ilmax
case(mld_pre_smooth_) call p%precv(ilev_)%set(val,info,pos=pos)
do ilev_ = ilmin, ilmax if (info /= 0) return
if (allocated(p%precv(ilev_)%sm)) then end do
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
end subroutine mld_dprecsetsm end subroutine mld_dprecsetsm
@ -843,13 +382,13 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos)
! Arguments ! Arguments
class(mld_dprec_type), intent(inout) :: p class(mld_dprec_type), intent(inout) :: p
class(mld_d_base_solver_type), intent(in) :: val class(mld_d_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos character(len=*), optional, intent(in) :: pos
! Local variables ! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax, ipos_ integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
character(len=*), parameter :: name='mld_precseti' character(len=*), parameter :: name='mld_precseti'
info = psb_success_ info = psb_success_
@ -873,19 +412,6 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos)
ilmax = nlev_ ilmax = nlev_
end if 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 if ((ilev_<1).or.(ilev_ > nlev_)) then
info = -1 info = -1
@ -894,83 +420,10 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos)
return return
endif endif
do ilev_ = ilmin, ilmax
select case(ipos_) call p%precv(ilev_)%set(val,info,pos=pos)
case(mld_pre_smooth_) if (info /= 0) return
do ilev_ = ilmin, ilmax end do
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
end subroutine mld_dprecsetsv 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 CSR ! Storage format CSR COO JAD
0030 ! IDIM; domain size is idim**3 0030 ! IDIM; domain size is idim**3
2 ! ISTOPC 2 ! ISTOPC

Write Preview
Loading…
Cancel
Save