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

mld2p4-smooth-twoside:

Browse Source 
mlprec/impl/level/mld_c_base_onelev_csetc.f90
 mlprec/impl/level/mld_c_base_onelev_cseti.F90
 mlprec/impl/level/mld_c_base_onelev_csetr.f90
 mlprec/impl/level/mld_c_base_onelev_setc.f90
 mlprec/impl/level/mld_c_base_onelev_seti.F90
 mlprec/impl/level/mld_c_base_onelev_setr.f90
 mlprec/impl/level/mld_d_base_onelev_cseti.F90
 mlprec/impl/level/mld_d_base_onelev_setc.f90
 mlprec/impl/level/mld_d_base_onelev_seti.F90
 mlprec/impl/level/mld_s_base_onelev_csetc.f90
 mlprec/impl/level/mld_s_base_onelev_cseti.F90
 mlprec/impl/level/mld_s_base_onelev_csetr.f90
 mlprec/impl/level/mld_s_base_onelev_setc.f90
 mlprec/impl/level/mld_s_base_onelev_seti.F90
 mlprec/impl/level/mld_s_base_onelev_setr.f90
 mlprec/impl/level/mld_z_base_onelev_csetc.f90
 mlprec/impl/level/mld_z_base_onelev_cseti.F90
 mlprec/impl/level/mld_z_base_onelev_csetr.f90
 mlprec/impl/level/mld_z_base_onelev_setc.f90
 mlprec/impl/level/mld_z_base_onelev_seti.F90
 mlprec/impl/level/mld_z_base_onelev_setr.f90
 mlprec/impl/mld_ccprecset.F90
 mlprec/impl/mld_cmlprec_aply.f90
 mlprec/impl/mld_cmlprec_bld.f90
 mlprec/impl/mld_cprecset.F90
 mlprec/impl/mld_dcprecset.F90
 mlprec/impl/mld_dmlprec_aply.f90
 mlprec/impl/mld_dmlprec_bld.f90
 mlprec/impl/mld_dprecbld.f90
 mlprec/impl/mld_dprecset.F90
 mlprec/impl/mld_scprecset.F90
 mlprec/impl/mld_smlprec_aply.f90
 mlprec/impl/mld_smlprec_bld.f90
 mlprec/impl/mld_sprecset.F90
 mlprec/impl/mld_zcprecset.F90
 mlprec/impl/mld_zmlprec_aply.f90
 mlprec/impl/mld_zmlprec_bld.f90
 mlprec/impl/mld_zprecset.F90
 mlprec/impl/solver/Makefile
 mlprec/impl/solver/mld_c_bwgs_solver_apply.f90
 mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90
 mlprec/impl/solver/mld_c_bwgs_solver_bld.f90
 mlprec/impl/solver/mld_d_mumps_solver_apply.F90
 mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90
 mlprec/impl/solver/mld_d_mumps_solver_bld.F90
 mlprec/impl/solver/mld_s_bwgs_solver_apply.f90
 mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90
 mlprec/impl/solver/mld_s_bwgs_solver_bld.f90
 mlprec/impl/solver/mld_s_mumps_solver_apply.F90
 mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90
 mlprec/impl/solver/mld_s_mumps_solver_bld.F90
 mlprec/impl/solver/mld_z_bwgs_solver_apply.f90
 mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90
 mlprec/impl/solver/mld_z_bwgs_solver_bld.f90
 mlprec/impl/solver/mld_z_mumps_solver_apply.F90
 mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90
 mlprec/impl/solver/mld_z_mumps_solver_bld.F90
 mlprec/mld_base_prec_type.F90
 mlprec/mld_c_gs_solver.f90
 mlprec/mld_c_onelev_mod.f90
 mlprec/mld_c_prec_mod.f90
 mlprec/mld_c_prec_type.f90
 mlprec/mld_d_gs_solver.f90
 mlprec/mld_d_onelev_mod.f90
 mlprec/mld_d_prec_type.f90
 mlprec/mld_s_gs_solver.f90
 mlprec/mld_s_onelev_mod.f90
 mlprec/mld_s_prec_mod.f90
 mlprec/mld_s_prec_type.f90
 mlprec/mld_z_gs_solver.f90
 mlprec/mld_z_onelev_mod.f90
 mlprec/mld_z_prec_mod.f90
 mlprec/mld_z_prec_type.f90
 tests/fileread/df_sample.f90
 tests/fileread/runs/dfs.inp
 tests/pdegen/runs/ppde.inp

Fixes for BWGS. Seems to be working, although it needs further testing.
stopcriterion
Salvatore Filippone 9 years ago
parent 6c1676a9c6
commit 2c28bf3e02
76 changed files with 4443 additions and 3061 deletions
Show Stats Download Patch File Download Diff File

36
mlprec/impl/level/mld_c_base_onelev_csetc.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_base_onelev_csetc(lv,what,val,info)
subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos)
use psb_base_mod
use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_csetc
@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info)
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='c_base_onelev_csetc'
integer(psb_ipk_) :: ival
@ -58,11 +60,35 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info)
ival = lv%stringval(val)
if (ival >= 0) then
call lv%set(what,ival,info)
call lv%set(what,ival,info,pos=pos)
else
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if

151
mlprec/impl/level/mld_c_base_onelev_cseti.F90
Unescape Escape View File

@ -36,10 +36,28 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_base_onelev_cseti(lv,what,val,info)
subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
use psb_base_mod
use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_cseti
use mld_c_jac_smoother
use mld_c_as_smoother
use mld_c_diag_solver
use mld_c_ilu_solver
use mld_c_id_solver
use mld_c_gs_solver
#if defined(HAVE_UMF_)
use mld_c_umf_solver
#endif
#if defined(HAVE_SLUDIST_)
use mld_c_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_c_slu_solver
#endif
#if defined(HAVE_MUMPS_)
use mld_c_mumps_solver
#endif
Implicit None
@ -48,13 +66,123 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info)
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
Integer(Psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='c_base_onelev_cseti'
type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold
type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold
type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold
type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold
type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold
type(mld_c_id_solver_type) :: mld_c_id_solver_mold
type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold
type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold
#if defined(HAVE_UMF_)
type(mld_c_umf_solver_type) :: mld_c_umf_solver_mold
#endif
#if defined(HAVE_SLUDIST_)
type(mld_c_sludist_solver_type) :: mld_c_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold
#endif
#if defined(HAVE_MUMPS_)
type(mld_c_mumps_solver_type) :: mld_c_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
info = psb_success_
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case (psb_toupper(what))
case ('SMOOTHER_TYPE')
select case (val)
case (mld_noprec_)
call lv%set(mld_c_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_c_id_solver_mold,info,pos=pos)
case (mld_jac_)
call lv%set(mld_c_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_c_diag_solver_mold,info,pos=pos)
case (mld_bjac_)
call lv%set(mld_c_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
case (mld_as_)
call lv%set(mld_c_as_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(lv%sm)) call lv%sm%default()
case('SUB_SOLVE')
select case (val)
case (mld_f_none_)
call lv%set(mld_c_id_solver_mold,info,pos=pos)
case (mld_diag_scale_)
call lv%set(mld_c_diag_solver_mold,info,pos=pos)
case (mld_gs_)
call lv%set(mld_c_gs_solver_mold,info,pos=pos)
case (mld_bwgs_)
call lv%set(mld_c_bwgs_solver_mold,info,pos=pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_c_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_c_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_c_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_c_umf_solver_mold,info,pos=pos)
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
case ('SMOOTHER_SWEEPS')
lv%parms%sweeps = val
@ -98,9 +226,20 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info)
lv%parms%coarse_solve = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

33
mlprec/impl/level/mld_c_base_onelev_csetr.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_base_onelev_csetr(lv,what,val,info)
subroutine mld_c_base_onelev_csetr(lv,what,val,info,pos)
use psb_base_mod
use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_csetr
@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info)
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='c_base_onelev_csetr'
call psb_erractionsave(err_act)
@ -68,9 +70,32 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info)
lv%parms%aggr_scale = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999

36
mlprec/impl/level/mld_c_base_onelev_setc.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_base_onelev_setc(lv,what,val,info)
subroutine mld_c_base_onelev_setc(lv,what,val,info,pos)
use psb_base_mod
use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setc
@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='c_base_onelev_setc'
integer(psb_ipk_) :: ival
@ -58,14 +60,36 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info)
ival = lv%stringval(val)
if (ival >= 0) then
call lv%set(what,ival,info)
call lv%set(what,ival,info,pos=pos)
else
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

153
mlprec/impl/level/mld_c_base_onelev_seti.F90
Unescape Escape View File

@ -36,10 +36,28 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_base_onelev_seti(lv,what,val,info)
subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
use psb_base_mod
use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_seti
use mld_c_jac_smoother
use mld_c_as_smoother
use mld_c_diag_solver
use mld_c_ilu_solver
use mld_c_id_solver
use mld_c_gs_solver
#if defined(HAVE_UMF_)
use mld_c_umf_solver
#endif
#if defined(HAVE_SLUDIST_)
use mld_c_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_c_slu_solver
#endif
#if defined(HAVE_MUMPS_)
use mld_c_mumps_solver
#endif
Implicit None
@ -48,14 +66,123 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
Integer(Psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='c_base_onelev_seti'
type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold
type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold
type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold
type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold
type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold
type(mld_c_id_solver_type) :: mld_c_id_solver_mold
type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold
type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold
#if defined(HAVE_UMF_)
type(mld_c_umf_solver_type) :: mld_c_umf_solver_mold
#endif
#if defined(HAVE_SLUDIST_)
type(mld_c_sludist_solver_type) :: mld_c_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold
#endif
#if defined(HAVE_MUMPS_)
type(mld_c_mumps_solver_type) :: mld_c_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
info = psb_success_
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case (what)
case (mld_smoother_type_)
select case (val)
case (mld_noprec_)
call lv%set(mld_c_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_c_id_solver_mold,info,pos=pos)
case (mld_jac_)
call lv%set(mld_c_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_c_diag_solver_mold,info,pos=pos)
case (mld_bjac_)
call lv%set(mld_c_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
case (mld_as_)
call lv%set(mld_c_as_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(lv%sm)) call lv%sm%default()
case(mld_sub_solve_)
select case (val)
case (mld_f_none_)
call lv%set(mld_c_id_solver_mold,info,pos=pos)
case (mld_diag_scale_)
call lv%set(mld_c_diag_solver_mold,info,pos=pos)
case (mld_gs_)
call lv%set(mld_c_gs_solver_mold,info,pos=pos)
case (mld_bwgs_)
call lv%set(mld_c_bwgs_solver_mold,info,pos=pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_c_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_c_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_c_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_c_umf_solver_mold,info,pos=pos)
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
case (mld_smoother_sweeps_)
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
@ -98,9 +225,21 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info)
lv%parms%coarse_solve = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

33
mlprec/impl/level/mld_c_base_onelev_setr.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_base_onelev_setr(lv,what,val,info)
subroutine mld_c_base_onelev_setr(lv,what,val,info,pos)
use psb_base_mod
use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setr
@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_setr(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='c_base_onelev_setr'
call psb_erractionsave(err_act)
@ -68,9 +70,32 @@ subroutine mld_c_base_onelev_setr(lv,what,val,info)
lv%parms%aggr_scale = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999

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

@ -71,14 +71,15 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='d_base_onelev_cseti'
type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold
type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold
type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold
type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold
type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold
type(mld_d_id_solver_type) :: mld_d_id_solver_mold
type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold
type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold
type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold
type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold
type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold
type(mld_d_id_solver_type) :: mld_d_id_solver_mold
type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold
type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold
#if defined(HAVE_UMF_)
type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold
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
@ -143,6 +144,9 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos)
case (mld_gs_)
call lv%set(mld_d_gs_solver_mold,info,pos=pos)
case (mld_bwgs_)
call lv%set(mld_d_bwgs_solver_mold,info,pos=pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
if (info == 0) then

1
mlprec/impl/level/mld_d_base_onelev_setc.f90
Unescape Escape View File

@ -90,7 +90,6 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info,pos)
end select
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

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

@ -71,12 +71,13 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='d_base_onelev_seti'
type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold
type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold
type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold
type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold
type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold
type(mld_d_id_solver_type) :: mld_d_id_solver_mold
type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold
type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold
type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold
type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold
type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold
type(mld_d_id_solver_type) :: mld_d_id_solver_mold
type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold
type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold
#if defined(HAVE_UMF_)
type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold
#endif
@ -142,6 +143,9 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos)
case (mld_gs_)
call lv%set(mld_d_gs_solver_mold,info,pos=pos)
case (mld_bwgs_)
call lv%set(mld_d_bwgs_solver_mold,info,pos=pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_d_ilu_solver_mold,info,pos=pos)

36
mlprec/impl/level/mld_s_base_onelev_csetc.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_base_onelev_csetc(lv,what,val,info)
subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos)
use psb_base_mod
use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_csetc
@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info)
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='s_base_onelev_csetc'
integer(psb_ipk_) :: ival
@ -58,11 +60,35 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info)
ival = lv%stringval(val)
if (ival >= 0) then
call lv%set(what,ival,info)
call lv%set(what,ival,info,pos=pos)
else
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if

151
mlprec/impl/level/mld_s_base_onelev_cseti.F90
Unescape Escape View File

@ -36,10 +36,28 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_base_onelev_cseti(lv,what,val,info)
subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
use psb_base_mod
use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_cseti
use mld_s_jac_smoother
use mld_s_as_smoother
use mld_s_diag_solver
use mld_s_ilu_solver
use mld_s_id_solver
use mld_s_gs_solver
#if defined(HAVE_UMF_)
use mld_s_umf_solver
#endif
#if defined(HAVE_SLUDIST_)
use mld_s_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_s_slu_solver
#endif
#if defined(HAVE_MUMPS_)
use mld_s_mumps_solver
#endif
Implicit None
@ -48,13 +66,123 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info)
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
Integer(Psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='s_base_onelev_cseti'
type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold
type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold
type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold
type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold
type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold
type(mld_s_id_solver_type) :: mld_s_id_solver_mold
type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold
type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold
#if defined(HAVE_UMF_)
type(mld_s_umf_solver_type) :: mld_s_umf_solver_mold
#endif
#if defined(HAVE_SLUDIST_)
type(mld_s_sludist_solver_type) :: mld_s_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold
#endif
#if defined(HAVE_MUMPS_)
type(mld_s_mumps_solver_type) :: mld_s_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
info = psb_success_
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case (psb_toupper(what))
case ('SMOOTHER_TYPE')
select case (val)
case (mld_noprec_)
call lv%set(mld_s_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_s_id_solver_mold,info,pos=pos)
case (mld_jac_)
call lv%set(mld_s_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_s_diag_solver_mold,info,pos=pos)
case (mld_bjac_)
call lv%set(mld_s_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
case (mld_as_)
call lv%set(mld_s_as_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(lv%sm)) call lv%sm%default()
case('SUB_SOLVE')
select case (val)
case (mld_f_none_)
call lv%set(mld_s_id_solver_mold,info,pos=pos)
case (mld_diag_scale_)
call lv%set(mld_s_diag_solver_mold,info,pos=pos)
case (mld_gs_)
call lv%set(mld_s_gs_solver_mold,info,pos=pos)
case (mld_bwgs_)
call lv%set(mld_s_bwgs_solver_mold,info,pos=pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_s_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_s_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_s_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_s_umf_solver_mold,info,pos=pos)
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
case ('SMOOTHER_SWEEPS')
lv%parms%sweeps = val
@ -98,9 +226,20 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info)
lv%parms%coarse_solve = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

33
mlprec/impl/level/mld_s_base_onelev_csetr.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_base_onelev_csetr(lv,what,val,info)
subroutine mld_s_base_onelev_csetr(lv,what,val,info,pos)
use psb_base_mod
use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_csetr
@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info)
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='s_base_onelev_csetr'
call psb_erractionsave(err_act)
@ -68,9 +70,32 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info)
lv%parms%aggr_scale = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999

36
mlprec/impl/level/mld_s_base_onelev_setc.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_base_onelev_setc(lv,what,val,info)
subroutine mld_s_base_onelev_setc(lv,what,val,info,pos)
use psb_base_mod
use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setc
@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='s_base_onelev_setc'
integer(psb_ipk_) :: ival
@ -58,14 +60,36 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info)
ival = lv%stringval(val)
if (ival >= 0) then
call lv%set(what,ival,info)
call lv%set(what,ival,info,pos=pos)
else
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

153
mlprec/impl/level/mld_s_base_onelev_seti.F90
Unescape Escape View File

@ -36,10 +36,28 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_base_onelev_seti(lv,what,val,info)
subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
use psb_base_mod
use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_seti
use mld_s_jac_smoother
use mld_s_as_smoother
use mld_s_diag_solver
use mld_s_ilu_solver
use mld_s_id_solver
use mld_s_gs_solver
#if defined(HAVE_UMF_)
use mld_s_umf_solver
#endif
#if defined(HAVE_SLUDIST_)
use mld_s_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_s_slu_solver
#endif
#if defined(HAVE_MUMPS_)
use mld_s_mumps_solver
#endif
Implicit None
@ -48,14 +66,123 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
Integer(Psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='s_base_onelev_seti'
type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold
type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold
type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold
type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold
type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold
type(mld_s_id_solver_type) :: mld_s_id_solver_mold
type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold
type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold
#if defined(HAVE_UMF_)
type(mld_s_umf_solver_type) :: mld_s_umf_solver_mold
#endif
#if defined(HAVE_SLUDIST_)
type(mld_s_sludist_solver_type) :: mld_s_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold
#endif
#if defined(HAVE_MUMPS_)
type(mld_s_mumps_solver_type) :: mld_s_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
info = psb_success_
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case (what)
case (mld_smoother_type_)
select case (val)
case (mld_noprec_)
call lv%set(mld_s_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_s_id_solver_mold,info,pos=pos)
case (mld_jac_)
call lv%set(mld_s_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_s_diag_solver_mold,info,pos=pos)
case (mld_bjac_)
call lv%set(mld_s_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
case (mld_as_)
call lv%set(mld_s_as_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(lv%sm)) call lv%sm%default()
case(mld_sub_solve_)
select case (val)
case (mld_f_none_)
call lv%set(mld_s_id_solver_mold,info,pos=pos)
case (mld_diag_scale_)
call lv%set(mld_s_diag_solver_mold,info,pos=pos)
case (mld_gs_)
call lv%set(mld_s_gs_solver_mold,info,pos=pos)
case (mld_bwgs_)
call lv%set(mld_s_bwgs_solver_mold,info,pos=pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_s_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_s_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_s_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_s_umf_solver_mold,info,pos=pos)
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
case (mld_smoother_sweeps_)
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
@ -98,9 +225,21 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info)
lv%parms%coarse_solve = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

33
mlprec/impl/level/mld_s_base_onelev_setr.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_base_onelev_setr(lv,what,val,info)
subroutine mld_s_base_onelev_setr(lv,what,val,info,pos)
use psb_base_mod
use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setr
@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_setr(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='s_base_onelev_setr'
call psb_erractionsave(err_act)
@ -68,9 +70,32 @@ subroutine mld_s_base_onelev_setr(lv,what,val,info)
lv%parms%aggr_scale = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999

36
mlprec/impl/level/mld_z_base_onelev_csetc.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_base_onelev_csetc(lv,what,val,info)
subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos)
use psb_base_mod
use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_csetc
@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info)
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='z_base_onelev_csetc'
integer(psb_ipk_) :: ival
@ -58,11 +60,35 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info)
ival = lv%stringval(val)
if (ival >= 0) then
call lv%set(what,ival,info)
call lv%set(what,ival,info,pos=pos)
else
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if

151
mlprec/impl/level/mld_z_base_onelev_cseti.F90
Unescape Escape View File

@ -36,10 +36,28 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_base_onelev_cseti(lv,what,val,info)
subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos)
use psb_base_mod
use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_cseti
use mld_z_jac_smoother
use mld_z_as_smoother
use mld_z_diag_solver
use mld_z_ilu_solver
use mld_z_id_solver
use mld_z_gs_solver
#if defined(HAVE_UMF_)
use mld_z_umf_solver
#endif
#if defined(HAVE_SLUDIST_)
use mld_z_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_z_slu_solver
#endif
#if defined(HAVE_MUMPS_)
use mld_z_mumps_solver
#endif
Implicit None
@ -48,13 +66,123 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info)
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
Integer(Psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='z_base_onelev_cseti'
type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold
type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold
type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold
type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold
type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold
type(mld_z_id_solver_type) :: mld_z_id_solver_mold
type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold
type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold
#if defined(HAVE_UMF_)
type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold
#endif
#if defined(HAVE_SLUDIST_)
type(mld_z_sludist_solver_type) :: mld_z_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_z_slu_solver_type) :: mld_z_slu_solver_mold
#endif
#if defined(HAVE_MUMPS_)
type(mld_z_mumps_solver_type) :: mld_z_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
info = psb_success_
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case (psb_toupper(what))
case ('SMOOTHER_TYPE')
select case (val)
case (mld_noprec_)
call lv%set(mld_z_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_z_id_solver_mold,info,pos=pos)
case (mld_jac_)
call lv%set(mld_z_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_z_diag_solver_mold,info,pos=pos)
case (mld_bjac_)
call lv%set(mld_z_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
case (mld_as_)
call lv%set(mld_z_as_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(lv%sm)) call lv%sm%default()
case('SUB_SOLVE')
select case (val)
case (mld_f_none_)
call lv%set(mld_z_id_solver_mold,info,pos=pos)
case (mld_diag_scale_)
call lv%set(mld_z_diag_solver_mold,info,pos=pos)
case (mld_gs_)
call lv%set(mld_z_gs_solver_mold,info,pos=pos)
case (mld_bwgs_)
call lv%set(mld_z_bwgs_solver_mold,info,pos=pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_z_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_z_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_z_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_z_umf_solver_mold,info,pos=pos)
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
case ('SMOOTHER_SWEEPS')
lv%parms%sweeps = val
@ -98,9 +226,20 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info)
lv%parms%coarse_solve = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

33
mlprec/impl/level/mld_z_base_onelev_csetr.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_base_onelev_csetr(lv,what,val,info)
subroutine mld_z_base_onelev_csetr(lv,what,val,info,pos)
use psb_base_mod
use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_csetr
@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info)
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='z_base_onelev_csetr'
call psb_erractionsave(err_act)
@ -68,9 +70,32 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info)
lv%parms%aggr_scale = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999

36
mlprec/impl/level/mld_z_base_onelev_setc.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_base_onelev_setc(lv,what,val,info)
subroutine mld_z_base_onelev_setc(lv,what,val,info,pos)
use psb_base_mod
use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setc
@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='z_base_onelev_setc'
integer(psb_ipk_) :: ival
@ -58,14 +60,36 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info)
ival = lv%stringval(val)
if (ival >= 0) then
call lv%set(what,ival,info)
call lv%set(what,ival,info,pos=pos)
else
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

153
mlprec/impl/level/mld_z_base_onelev_seti.F90
Unescape Escape View File

@ -36,10 +36,28 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_base_onelev_seti(lv,what,val,info)
subroutine mld_z_base_onelev_seti(lv,what,val,info,pos)
use psb_base_mod
use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_seti
use mld_z_jac_smoother
use mld_z_as_smoother
use mld_z_diag_solver
use mld_z_ilu_solver
use mld_z_id_solver
use mld_z_gs_solver
#if defined(HAVE_UMF_)
use mld_z_umf_solver
#endif
#if defined(HAVE_SLUDIST_)
use mld_z_sludist_solver
#endif
#if defined(HAVE_SLU_)
use mld_z_slu_solver
#endif
#if defined(HAVE_MUMPS_)
use mld_z_mumps_solver
#endif
Implicit None
@ -48,14 +66,123 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
Integer(Psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='z_base_onelev_seti'
type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold
type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold
type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold
type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold
type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold
type(mld_z_id_solver_type) :: mld_z_id_solver_mold
type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold
type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold
#if defined(HAVE_UMF_)
type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold
#endif
#if defined(HAVE_SLUDIST_)
type(mld_z_sludist_solver_type) :: mld_z_sludist_solver_mold
#endif
#if defined(HAVE_SLU_)
type(mld_z_slu_solver_type) :: mld_z_slu_solver_mold
#endif
#if defined(HAVE_MUMPS_)
type(mld_z_mumps_solver_type) :: mld_z_mumps_solver_mold
#endif
call psb_erractionsave(err_act)
info = psb_success_
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case (what)
case (mld_smoother_type_)
select case (val)
case (mld_noprec_)
call lv%set(mld_z_base_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_z_id_solver_mold,info,pos=pos)
case (mld_jac_)
call lv%set(mld_z_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_z_diag_solver_mold,info,pos=pos)
case (mld_bjac_)
call lv%set(mld_z_jac_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
case (mld_as_)
call lv%set(mld_z_as_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(lv%sm)) call lv%sm%default()
case(mld_sub_solve_)
select case (val)
case (mld_f_none_)
call lv%set(mld_z_id_solver_mold,info,pos=pos)
case (mld_diag_scale_)
call lv%set(mld_z_diag_solver_mold,info,pos=pos)
case (mld_gs_)
call lv%set(mld_z_gs_solver_mold,info,pos=pos)
case (mld_bwgs_)
call lv%set(mld_z_bwgs_solver_mold,info,pos=pos)
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
if (info == 0) then
select case(ipos_)
case(mld_pre_smooth_)
call lv%sm%sv%set('SUB_SOLVE',val,info)
case (mld_post_smooth_)
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
case default
! Impossible!!
info = psb_err_internal_error_
end select
end if
#ifdef HAVE_SLU_
case (mld_slu_)
call lv%set(mld_z_slu_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
call lv%set(mld_z_sludist_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
call lv%set(mld_z_mumps_solver_mold,info,pos=pos)
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
call lv%set(mld_z_umf_solver_mold,info,pos=pos)
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
case (mld_smoother_sweeps_)
lv%parms%sweeps = val
lv%parms%sweeps_pre = val
@ -98,9 +225,21 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info)
lv%parms%coarse_solve = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)

33
mlprec/impl/level/mld_z_base_onelev_setr.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_base_onelev_setr(lv,what,val,info)
subroutine mld_z_base_onelev_setr(lv,what,val,info,pos)
use psb_base_mod
use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setr
@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_setr(lv,what,val,info)
integer(psb_ipk_), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=*), optional, intent(in) :: pos
! Local
integer(psb_ipk_) :: ipos_, err_act
character(len=20) :: name='z_base_onelev_setr'
call psb_erractionsave(err_act)
@ -68,9 +70,32 @@ subroutine mld_z_base_onelev_setr(lv,what,val,info)
lv%parms%aggr_scale = val
case default
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
if (present(pos)) then
select case(psb_toupper(trim(pos)))
case('PRE')
ipos_ = mld_pre_smooth_
case('POST')
ipos_ = mld_post_smooth_
case default
ipos_ = mld_pre_smooth_
end select
else
ipos_ = mld_pre_smooth_
end if
select case(ipos_)
case(mld_pre_smooth_)
if (allocated(lv%sm)) then
call lv%sm%set(what,val,info)
end if
case (mld_post_smooth_)
if (allocated(lv%sm2a)) then
call lv%sm2a%set(what,val,info)
end if
case default
! Impossible!!
info = psb_err_internal_error_
end select
end select
if (info /= psb_success_) goto 9999

447
mlprec/impl/mld_ccprecset.F90
Unescape Escape View File

@ -76,7 +76,7 @@
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_ccprecseti(p,what,val,info,ilev)
subroutine mld_ccprecseti(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_c_prec_mod, mld_protect_name => mld_ccprecseti
@ -102,6 +102,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_
@ -144,38 +145,20 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
!
! Rules for fine level are slightly different.
!
select case(psb_toupper(trim(what)))
case('SMOOTHER_TYPE')
call onelev_set_smoother(p%precv(ilev_),val,info)
case('SUB_SOLVE')
call onelev_set_solver(p%precv(ilev_),val,info)
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
call p%precv(ilev_)%set(what,val,info)
case default
call p%precv(ilev_)%set(what,val,info)
end select
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (ilev_ > 1) then
select case(psb_toupper(what))
case('SMOOTHER_TYPE')
call onelev_set_smoother(p%precv(ilev_),val,info)
case('SUB_SOLVE')
call onelev_set_solver(p%precv(ilev_),val,info)
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
& 'COARSE_MAT')
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
case('COARSE_SUBSOLVE')
if (ilev_ /= nlev_) then
@ -184,7 +167,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
info = -2
return
end if
call onelev_set_solver(p%precv(ilev_),val,info)
call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos)
case('COARSE_SOLVE')
if (ilev_ /= nlev_) then
write(psb_err_unit,*) name,&
@ -192,38 +175,34 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
info = -2
return
end if
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),val,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
#if defined(HAVE_SLU_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
end select
endif
case('COARSE_SWEEPS')
if (ilev_ /= nlev_) then
@ -232,7 +211,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
case('COARSE_FILLIN')
if (ilev_ /= nlev_) then
@ -241,9 +220,10 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
case default
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end select
endif
@ -254,33 +234,12 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
! levels
!
select case(psb_toupper(trim(what)))
case('SUB_SOLVE')
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%precv(ilev_)%sm)) then
write(psb_err_unit,*) name,&
& ': Error: uninitialized preconditioner component,',&
& ' should call MLD_PRECINIT'
info = -1
return
endif
call onelev_set_solver(p%precv(ilev_),val,info)
end do
case('SUB_RESTR','SUB_PROL',&
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case('SMOOTHER_SWEEPS')
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case('SMOOTHER_TYPE')
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 onelev_set_smoother(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
@ -288,334 +247,68 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','AGGR_FILTER')
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case('COARSE_MAT')
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_MAT',val,info)
call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos)
end if
case('COARSE_SOLVE')
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
#if defined(HAVE_SLU_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
end select
endif
case('COARSE_SUBSOLVE')
if (nlev_ > 1) then
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
endif
case('COARSE_SWEEPS')
if (nlev_ > 1) then
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
end if
case('COARSE_FILLIN')
if (nlev_ > 1) then
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
end if
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select
endif
contains
subroutine onelev_set_smoother(level,val,info)
type(mld_c_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_noprec_)
if (allocated(level%sm)) then
select type (sm => level%sm)
type is (mld_c_base_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_base_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_base_smoother_type ::&
& level%sm, stat=info)
if (info ==0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_jac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_jac_smoother_type :: &
& level%sm, stat=info)
if (info == 0) allocate(mld_c_diag_solver_type :: &
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_diag_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_bjac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_jac_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_as_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_as_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_as_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_as_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(level%sm)) &
& call level%sm%default()
end subroutine onelev_set_smoother
subroutine onelev_set_solver(level,val,info)
type(mld_c_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_f_none_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_id_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_id_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_diag_scale_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_diag_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_diag_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_diag_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_gs_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_gs_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_gs_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_gs_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
else
endif
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_ilu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_ilu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
call level%sm%sv%set('SUB_SOLVE',val,info)
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#ifdef HAVE_SLU_
case (mld_slu_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_slu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_slu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_slu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_mumps_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_mumps_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_mumps_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
end subroutine onelev_set_solver
end subroutine mld_ccprecseti
!
@ -657,7 +350,7 @@ end subroutine mld_ccprecseti
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_ccprecsetc(p,what,string,info,ilev)
subroutine mld_ccprecsetc(p,what,string,info,ilev,pos)
use psb_base_mod
use mld_c_prec_mod, mld_protect_name => mld_ccprecsetc
@ -670,6 +363,7 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev)
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_,val
@ -698,9 +392,9 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev)
val = mld_stringval(string)
if (val >=0) then
call p%set(what,val,info,ilev=ilev)
call p%set(what,val,info,ilev=ilev,pos=pos)
else
call p%precv(ilev_)%set(what,string,info)
call p%precv(ilev_)%set(what,string,info,pos=pos)
end if
end subroutine mld_ccprecsetc
@ -744,7 +438,7 @@ end subroutine mld_ccprecsetc
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_ccprecsetr(p,what,val,info,ilev)
subroutine mld_ccprecsetr(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_c_prec_mod, mld_protect_name => mld_ccprecsetr
@ -757,6 +451,7 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev)
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_,nlev_
@ -793,7 +488,7 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev)
!
if (present(ilev)) then
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (.not.present(ilev)) then
!
@ -803,19 +498,19 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev)
select case(psb_toupper(what))
case('COARSE_ILUTHRS')
ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info)
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_THRESH')
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_THRESH',thr,info)
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select

134
mlprec/impl/mld_cmlprec_aply.f90
Unescape Escape View File

@ -405,10 +405,10 @@ contains
implicit none
! Arguments
integer(psb_ipk_) :: level
type(mld_cprec_type), intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
integer(psb_ipk_) :: level
type(mld_cprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
@ -434,7 +434,6 @@ contains
ictxt = p%precv(level)%base_desc%get_context()
call psb_info(ictxt, me, np)
if (level > 1) then
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
@ -539,7 +538,6 @@ contains
end if
! This is one step of post-smoothing
if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then
@ -572,7 +570,7 @@ contains
end if
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(cone,&
call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
@ -621,13 +619,17 @@ contains
!
if (level < nlev) then
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -830,6 +832,13 @@ contains
case(mld_twoside_smooth_)
! CHECK
if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then
write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999
end if
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info)
@ -866,10 +875,19 @@ contains
else
sweeps = p%precv(level)%parms%sweeps
end if
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
@ -930,10 +948,18 @@ contains
else
sweeps = p%precv(level)%parms%sweeps_pre
end if
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
@ -1043,7 +1069,7 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
level = 1
call psb_geaxpby(cone,x,czero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info)
call mlprec_wrk(level)%vy2l%set(czero)
call mlprec_wrk(level)%vy2l%zero()
call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info)
@ -1090,12 +1116,12 @@ contains
implicit none
! Arguments
integer(psb_ipk_) :: level
type(mld_cprec_type), intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: level
type(mld_cprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: ictxt,np,me
@ -1122,7 +1148,9 @@ contains
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
if(debug_level > 1) then
write(debug_unit,*) me,' inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
@ -1160,7 +1188,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during ADD smoother_apply')
goto 9999
end if
@ -1250,25 +1278,25 @@ contains
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(cone,&
call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%vx2l,cone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
else
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(cone,&
call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
@ -1302,13 +1330,13 @@ contains
else
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(cone,&
call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
@ -1386,7 +1414,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during PRE smoother_apply')
goto 9999
end if
@ -1484,7 +1512,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during PRE smoother_apply')
goto 9999
end if
else
@ -1530,19 +1558,28 @@ contains
if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
else
sweeps = p%precv(level)%parms%sweeps
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
@ -1602,16 +1639,21 @@ contains
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during 2-POST smoother_apply')
goto 9999
end if

12
mlprec/impl/mld_cmlprec_bld.f90
Unescape Escape View File

@ -495,10 +495,16 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold)
if ((info == psb_success_).and.(i>1)) then
call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(p%precv(i)%sm2a)) then
call p%precv(i)%sm2a%build(a,desc_a,upd_,info,&
& amold=amold,vmold=vmold,imold=imold)
p%precv(i)%sm2 => p%precv(i)%sm2a
else
p%precv(i)%sm2 => p%precv(i)%sm
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')

487
mlprec/impl/mld_cprecset.F90
Unescape Escape View File

@ -76,7 +76,7 @@
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_cprecseti(p,what,val,info,ilev)
subroutine mld_cprecseti(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_c_prec_mod, mld_protect_name => mld_cprecseti
@ -101,6 +101,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_
@ -141,39 +142,21 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
if (present(ilev)) then
if (ilev_ == 1) then
!
! Rules for fine level are slightly different.
!
select case(what)
case(mld_smoother_type_)
call onelev_set_smoother(p%precv(ilev_),val,info)
case(mld_sub_solve_)
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
call p%precv(ilev_)%set(what,val,info)
case default
call p%precv(ilev_)%set(what,val,info)
end select
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (ilev_ > 1) then
select case(what)
case(mld_smoother_type_)
call onelev_set_smoother(p%precv(ilev_),val,info)
case(mld_sub_solve_)
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
& mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,&
& mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_coarse_mat_)
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
case(mld_coarse_subsolve_)
if (ilev_ /= nlev_) then
@ -182,7 +165,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
info = -2
return
end if
call onelev_set_solver(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos)
case(mld_coarse_solve_)
if (ilev_ /= nlev_) then
write(psb_err_unit,*) name,&
@ -192,30 +175,30 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
end if
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),val,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos)
#if defined(HAVE_SLU_)
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
end select
endif
@ -226,7 +209,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
case(mld_coarse_fillin_)
if (ilev_ /= nlev_) then
@ -235,9 +218,9 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
case default
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end select
endif
@ -248,33 +231,12 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
! levels
!
select case(what)
case(mld_sub_solve_)
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%precv(ilev_)%sm)) then
write(psb_err_unit,*) name,&
& ': Error: uninitialized preconditioner component,',&
& ' should call MLD_PRECINIT'
info = -1
return
endif
call onelev_set_solver(p%precv(ilev_),val,info)
end do
case(mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
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 p%precv(ilev_)%set(what,val,info)
end do
case(mld_smoother_sweeps_)
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_smoother_type_)
do ilev_=1,max(1,nlev_-1)
call onelev_set_smoother(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,&
@ -282,336 +244,73 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
& mld_smoother_pos_,mld_aggr_omega_alg_,&
& mld_aggr_eig_,mld_aggr_filter_)
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
case(mld_coarse_mat_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_mat_,val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos)
end if
case(mld_coarse_solve_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
#elif defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
#if defined(HAVE_SLU_)
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
end select
endif
case(mld_coarse_subsolve_)
if (nlev_ > 1) then
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
endif
case(mld_coarse_sweeps_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
end if
case(mld_coarse_fillin_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
end if
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select
endif
contains
subroutine onelev_set_smoother(level,val,info)
type(mld_c_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_noprec_)
if (allocated(level%sm)) then
select type (sm => level%sm)
type is (mld_c_base_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_base_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_base_smoother_type ::&
& level%sm, stat=info)
if (info ==0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_jac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_jac_smoother_type :: &
& level%sm, stat=info)
if (info == 0) allocate(mld_c_diag_solver_type :: &
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_diag_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_bjac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_jac_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_as_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_c_as_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_c_as_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_as_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(level%sm)) &
& call level%sm%default()
end subroutine onelev_set_smoother
subroutine onelev_set_solver(level,val,info)
type(mld_c_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_f_none_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_id_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_id_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_diag_scale_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_diag_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_diag_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_diag_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_gs_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_gs_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_gs_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_gs_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_ilu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_ilu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
call level%sm%sv%set(mld_sub_solve_,val,info)
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#ifdef HAVE_SLU_
case (mld_slu_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_slu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_slu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_slu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_c_mumps_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_c_mumps_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_c_mumps_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
end if
end if
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
end subroutine onelev_set_solver
end subroutine mld_cprecseti
subroutine mld_cprecsetsm(p,val,info,ilev)
subroutine mld_cprecsetsm(p,val,info,ilev,pos)
use psb_base_mod
use mld_c_prec_mod, mld_protect_name => mld_cprecsetsm
@ -623,6 +322,7 @@ subroutine mld_cprecsetsm(p,val,info,ilev)
class(mld_c_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
@ -658,23 +358,13 @@ subroutine mld_cprecsetsm(p,val,info,ilev)
do ilev_ = ilmin, ilmax
if (allocated(p%precv(ilev_)%sm)) then
if (allocated(p%precv(ilev_)%sm%sv)) then
deallocate(p%precv(ilev_)%sm%sv)
endif
deallocate(p%precv(ilev_)%sm)
end if
#ifdef HAVE_MOLD
allocate(p%precv(ilev_)%sm,mold=val)
#else
allocate(p%precv(ilev_)%sm,source=val)
#endif
call p%precv(ilev_)%sm%default()
call p%precv(ilev_)%set(val,info,pos=pos)
if (info /= 0) return
end do
end subroutine mld_cprecsetsm
subroutine mld_cprecsetsv(p,val,info,ilev)
subroutine mld_cprecsetsv(p,val,info,ilev,pos)
use psb_base_mod
use mld_c_prec_mod, mld_protect_name => mld_cprecsetsv
@ -686,6 +376,7 @@ subroutine mld_cprecsetsv(p,val,info,ilev)
class(mld_c_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
@ -720,43 +411,11 @@ subroutine mld_cprecsetsv(p,val,info,ilev)
return
endif
do ilev_ = ilmin, ilmax
if (allocated(p%precv(ilev_)%sm)) then
if (allocated(p%precv(ilev_)%sm%sv)) then
if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then
deallocate(p%precv(ilev_)%sm%sv,stat=info)
if (info /= 0) then
info = 3111
return
end if
end if
if (.not.allocated(p%precv(ilev_)%sm%sv)) then
#ifdef HAVE_MOLD
allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info)
#else
allocate(p%precv(ilev_)%sm%sv,source=val,stat=info)
#endif
if (info /= 0) then
info = 3111
return
end if
end if
end if
call p%precv(ilev_)%sm%sv%default()
else
info = 3111
write(psb_err_unit,*) name,&
&': Error: uninitialized preconditioner component,',&
&' should call MLD_PRECINIT/MLD_PRECSET'
return
end if
call p%precv(ilev_)%set(val,info,pos=pos)
if (info /= 0) return
end do
end subroutine mld_cprecsetsv
!
@ -798,7 +457,7 @@ end subroutine mld_cprecsetsv
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_cprecsetc(p,what,string,info,ilev)
subroutine mld_cprecsetc(p,what,string,info,ilev,pos)
use psb_base_mod
use mld_c_prec_mod, mld_protect_name => mld_cprecsetc
@ -811,6 +470,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev)
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_,val
@ -838,7 +498,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev)
endif
val = mld_stringval(string)
if (val >=0) call p%set(what,val,info,ilev=ilev)
if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos)
end subroutine mld_cprecsetc
@ -882,7 +542,7 @@ end subroutine mld_cprecsetc
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_cprecsetr(p,what,val,info,ilev)
subroutine mld_cprecsetr(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_c_prec_mod, mld_protect_name => mld_cprecsetr
@ -895,6 +555,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_,nlev_
@ -931,7 +592,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
!
if (present(ilev)) then
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (.not.present(ilev)) then
!
@ -941,19 +602,19 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
select case(what)
case(mld_coarse_iluthrs_)
ilev_=nlev_
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info)
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos)
case(mld_aggr_thresh_)
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select

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

@ -137,6 +137,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
&': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
if (psb_toupper(what) == 'COARSE_AGGR_SIZE') then
p%coarse_aggr_size = max(val,-1)
return
@ -195,7 +196,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,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)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
@ -264,7 +265,6 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos)
end if
case('COARSE_SOLVE')
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val)
@ -279,7 +279,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,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)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)

59
mlprec/impl/mld_dmlprec_aply.f90
Unescape Escape View File

@ -405,10 +405,10 @@ contains
implicit none
! Arguments
integer(psb_ipk_) :: level
integer(psb_ipk_) :: level
type(mld_dprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
@ -886,7 +886,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
& sweeps,work,info)
end if
if (info /= psb_success_) then
@ -1117,12 +1117,12 @@ contains
implicit none
! Arguments
integer(psb_ipk_) :: level
type(mld_dprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: level
type(mld_dprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: ictxt,np,me
@ -1189,7 +1189,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during ADD smoother_apply')
goto 9999
end if
@ -1264,7 +1264,7 @@ contains
& a_err='Error during prolongation')
goto 9999
end if
!
! Compute the residual
!
@ -1285,10 +1285,10 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
else
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm2%apply(done,&
@ -1297,10 +1297,10 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
end if
case('T','C')
@ -1337,7 +1337,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
@ -1361,7 +1361,7 @@ contains
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
& done,mlprec_wrk(level)%vy2l,&
@ -1415,7 +1415,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during PRE smoother_apply')
goto 9999
end if
@ -1439,7 +1439,7 @@ contains
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
& done,mlprec_wrk(level)%vy2l,&
@ -1480,7 +1480,7 @@ contains
& a_err='Error in recursive call')
goto 9999
end if
!
! Apply the prolongator
!
@ -1492,7 +1492,7 @@ contains
& a_err='Error during prolongation')
goto 9999
end if
!
! Compute the residual
!
@ -1513,7 +1513,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during PRE smoother_apply')
goto 9999
end if
else
@ -1577,12 +1577,13 @@ contains
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 1st smoother_apply')
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
!
! Compute the residual (at all levels but the coarsest one)
! and call recursively
@ -1608,7 +1609,7 @@ contains
& a_err='Error in recursive call')
goto 9999
end if
!
! Apply the prolongator
@ -1616,13 +1617,13 @@ contains
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
& done,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
!
! Compute the residual
!
@ -1653,7 +1654,7 @@ contains
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during 2nd smoother_apply')
& a_err='Error during 2-POST smoother_apply')
goto 9999
end if

12
mlprec/impl/mld_dmlprec_bld.f90
Unescape Escape View File

@ -495,10 +495,16 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold)
p%precv(i)%sm2 => p%precv(i)%sm
if ((info == psb_success_).and.(i>1)) then
call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(p%precv(i)%sm2a)) then
call p%precv(i)%sm2a%build(a,desc_a,upd_,info,&
& amold=amold,vmold=vmold,imold=imold)
p%precv(i)%sm2 => p%precv(i)%sm2a
else
p%precv(i)%sm2 => p%precv(i)%sm
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')

12
mlprec/impl/mld_dprecbld.f90
Unescape Escape View File

@ -173,15 +173,23 @@ subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold,imold)
& a_err='One level preconditioner check.')
goto 9999
endif
call p%precv(1)%sm%build(a,desc_a,upd_,info,&
& amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(p%precv(1)%sm2a)) then
call p%precv(1)%sm%build(a,desc_a,upd_,info,&
& amold=amold,vmold=vmold,imold=imold)
p%precv(1)%sm2 => p%precv(1)%sm2a
else
p%precv(1)%sm2 => p%precv(i)%sm
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')
goto 9999
endif
!
! Number of levels > 1
!

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

@ -328,16 +328,16 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos)
implicit none
! Arguments
class(mld_dprec_type), target, intent(inout) :: p
class(mld_d_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
class(mld_dprec_type), intent(inout) :: p
class(mld_d_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
character(len=*), parameter :: name='mld_precseti'
info = psb_success_
if (.not.allocated(p%precv)) then
@ -365,12 +365,13 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos)
& ': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
do ilev_ = ilmin, ilmax
call p%precv(ilev_)%set(val,info,pos=pos)
if (info /= 0) return
end do
end subroutine mld_dprecsetsm
subroutine mld_dprecsetsv(p,val,info,ilev,pos)
@ -382,14 +383,14 @@ 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
character(len=*), parameter :: name='mld_precseti'
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
character(len=*), parameter :: name='mld_precseti'
info = psb_success_
@ -411,7 +412,7 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos)
ilmin = 1
ilmax = nlev_
end if
if ((ilev_<1).or.(ilev_ > nlev_)) then
info = -1
@ -564,7 +565,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev,pos)
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_,nlev_

447
mlprec/impl/mld_scprecset.F90
Unescape Escape View File

@ -76,7 +76,7 @@
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_scprecseti(p,what,val,info,ilev)
subroutine mld_scprecseti(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_s_prec_mod, mld_protect_name => mld_scprecseti
@ -102,6 +102,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_
@ -144,38 +145,20 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
!
! Rules for fine level are slightly different.
!
select case(psb_toupper(trim(what)))
case('SMOOTHER_TYPE')
call onelev_set_smoother(p%precv(ilev_),val,info)
case('SUB_SOLVE')
call onelev_set_solver(p%precv(ilev_),val,info)
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
call p%precv(ilev_)%set(what,val,info)
case default
call p%precv(ilev_)%set(what,val,info)
end select
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (ilev_ > 1) then
select case(psb_toupper(what))
case('SMOOTHER_TYPE')
call onelev_set_smoother(p%precv(ilev_),val,info)
case('SUB_SOLVE')
call onelev_set_solver(p%precv(ilev_),val,info)
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
& 'COARSE_MAT')
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
case('COARSE_SUBSOLVE')
if (ilev_ /= nlev_) then
@ -184,7 +167,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
info = -2
return
end if
call onelev_set_solver(p%precv(ilev_),val,info)
call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos)
case('COARSE_SOLVE')
if (ilev_ /= nlev_) then
write(psb_err_unit,*) name,&
@ -192,38 +175,34 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
info = -2
return
end if
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),val,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
#if defined(HAVE_SLU_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
end select
endif
case('COARSE_SWEEPS')
if (ilev_ /= nlev_) then
@ -232,7 +211,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
case('COARSE_FILLIN')
if (ilev_ /= nlev_) then
@ -241,9 +220,10 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
case default
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end select
endif
@ -254,33 +234,12 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
! levels
!
select case(psb_toupper(trim(what)))
case('SUB_SOLVE')
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%precv(ilev_)%sm)) then
write(psb_err_unit,*) name,&
& ': Error: uninitialized preconditioner component,',&
& ' should call MLD_PRECINIT'
info = -1
return
endif
call onelev_set_solver(p%precv(ilev_),val,info)
end do
case('SUB_RESTR','SUB_PROL',&
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case('SMOOTHER_SWEEPS')
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case('SMOOTHER_TYPE')
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 onelev_set_smoother(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
@ -288,334 +247,68 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','AGGR_FILTER')
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case('COARSE_MAT')
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_MAT',val,info)
call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos)
end if
case('COARSE_SOLVE')
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
#if defined(HAVE_SLU_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
end select
endif
case('COARSE_SUBSOLVE')
if (nlev_ > 1) then
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
endif
case('COARSE_SWEEPS')
if (nlev_ > 1) then
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
end if
case('COARSE_FILLIN')
if (nlev_ > 1) then
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
end if
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select
endif
contains
subroutine onelev_set_smoother(level,val,info)
type(mld_s_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_noprec_)
if (allocated(level%sm)) then
select type (sm => level%sm)
type is (mld_s_base_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_s_base_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_s_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_base_smoother_type ::&
& level%sm, stat=info)
if (info ==0) allocate(mld_s_id_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_jac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_s_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_s_jac_smoother_type :: &
& level%sm, stat=info)
if (info == 0) allocate(mld_s_diag_solver_type :: &
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_s_diag_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_bjac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_s_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_s_jac_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_as_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_s_as_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_s_as_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_as_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(level%sm)) &
& call level%sm%default()
end subroutine onelev_set_smoother
subroutine onelev_set_solver(level,val,info)
type(mld_s_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_f_none_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_id_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_id_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_diag_scale_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_diag_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_diag_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_diag_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_gs_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_gs_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_gs_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_gs_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
else
endif
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_ilu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_ilu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
call level%sm%sv%set('SUB_SOLVE',val,info)
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#ifdef HAVE_SLU_
case (mld_slu_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_slu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_slu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_slu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_mumps_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_mumps_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_mumps_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
end subroutine onelev_set_solver
end subroutine mld_scprecseti
!
@ -657,7 +350,7 @@ end subroutine mld_scprecseti
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_scprecsetc(p,what,string,info,ilev)
subroutine mld_scprecsetc(p,what,string,info,ilev,pos)
use psb_base_mod
use mld_s_prec_mod, mld_protect_name => mld_scprecsetc
@ -670,6 +363,7 @@ subroutine mld_scprecsetc(p,what,string,info,ilev)
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_,val
@ -698,9 +392,9 @@ subroutine mld_scprecsetc(p,what,string,info,ilev)
val = mld_stringval(string)
if (val >=0) then
call p%set(what,val,info,ilev=ilev)
call p%set(what,val,info,ilev=ilev,pos=pos)
else
call p%precv(ilev_)%set(what,string,info)
call p%precv(ilev_)%set(what,string,info,pos=pos)
end if
end subroutine mld_scprecsetc
@ -744,7 +438,7 @@ end subroutine mld_scprecsetc
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_scprecsetr(p,what,val,info,ilev)
subroutine mld_scprecsetr(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_s_prec_mod, mld_protect_name => mld_scprecsetr
@ -757,6 +451,7 @@ subroutine mld_scprecsetr(p,what,val,info,ilev)
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_,nlev_
@ -793,7 +488,7 @@ subroutine mld_scprecsetr(p,what,val,info,ilev)
!
if (present(ilev)) then
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (.not.present(ilev)) then
!
@ -803,19 +498,19 @@ subroutine mld_scprecsetr(p,what,val,info,ilev)
select case(psb_toupper(what))
case('COARSE_ILUTHRS')
ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info)
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_THRESH')
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_THRESH',thr,info)
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select

134
mlprec/impl/mld_smlprec_aply.f90
Unescape Escape View File

@ -405,10 +405,10 @@ contains
implicit none
! Arguments
integer(psb_ipk_) :: level
type(mld_sprec_type), intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
integer(psb_ipk_) :: level
type(mld_sprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
@ -434,7 +434,6 @@ contains
ictxt = p%precv(level)%base_desc%get_context()
call psb_info(ictxt, me, np)
if (level > 1) then
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
@ -539,7 +538,6 @@ contains
end if
! This is one step of post-smoothing
if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then
@ -572,7 +570,7 @@ contains
end if
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(sone,&
call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
@ -621,13 +619,17 @@ contains
!
if (level < nlev) then
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -830,6 +832,13 @@ contains
case(mld_twoside_smooth_)
! CHECK
if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then
write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999
end if
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info)
@ -866,10 +875,19 @@ contains
else
sweeps = p%precv(level)%parms%sweeps
end if
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
@ -930,10 +948,18 @@ contains
else
sweeps = p%precv(level)%parms%sweeps_pre
end if
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
@ -1043,7 +1069,7 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
level = 1
call psb_geaxpby(sone,x,szero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info)
call mlprec_wrk(level)%vy2l%set(szero)
call mlprec_wrk(level)%vy2l%zero()
call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info)
@ -1090,12 +1116,12 @@ contains
implicit none
! Arguments
integer(psb_ipk_) :: level
type(mld_sprec_type), intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: level
type(mld_sprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: ictxt,np,me
@ -1122,7 +1148,9 @@ contains
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
if(debug_level > 1) then
write(debug_unit,*) me,' inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
@ -1160,7 +1188,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during ADD smoother_apply')
goto 9999
end if
@ -1250,25 +1278,25 @@ contains
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(sone,&
call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%vx2l,sone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
else
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(sone,&
call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
@ -1302,13 +1330,13 @@ contains
else
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(sone,&
call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
@ -1386,7 +1414,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during PRE smoother_apply')
goto 9999
end if
@ -1484,7 +1512,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during PRE smoother_apply')
goto 9999
end if
else
@ -1530,19 +1558,28 @@ contains
if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
else
sweeps = p%precv(level)%parms%sweeps
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
@ -1602,16 +1639,21 @@ contains
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during 2-POST smoother_apply')
goto 9999
end if

12
mlprec/impl/mld_smlprec_bld.f90
Unescape Escape View File

@ -495,10 +495,16 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold)
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold)
if ((info == psb_success_).and.(i>1)) then
call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(p%precv(i)%sm2a)) then
call p%precv(i)%sm2a%build(a,desc_a,upd_,info,&
& amold=amold,vmold=vmold,imold=imold)
p%precv(i)%sm2 => p%precv(i)%sm2a
else
p%precv(i)%sm2 => p%precv(i)%sm
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')

487
mlprec/impl/mld_sprecset.F90
Unescape Escape View File

@ -76,7 +76,7 @@
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_sprecseti(p,what,val,info,ilev)
subroutine mld_sprecseti(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_s_prec_mod, mld_protect_name => mld_sprecseti
@ -101,6 +101,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_
@ -141,39 +142,21 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
if (present(ilev)) then
if (ilev_ == 1) then
!
! Rules for fine level are slightly different.
!
select case(what)
case(mld_smoother_type_)
call onelev_set_smoother(p%precv(ilev_),val,info)
case(mld_sub_solve_)
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
call p%precv(ilev_)%set(what,val,info)
case default
call p%precv(ilev_)%set(what,val,info)
end select
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (ilev_ > 1) then
select case(what)
case(mld_smoother_type_)
call onelev_set_smoother(p%precv(ilev_),val,info)
case(mld_sub_solve_)
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
& mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,&
& mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_coarse_mat_)
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
case(mld_coarse_subsolve_)
if (ilev_ /= nlev_) then
@ -182,7 +165,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
info = -2
return
end if
call onelev_set_solver(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos)
case(mld_coarse_solve_)
if (ilev_ /= nlev_) then
write(psb_err_unit,*) name,&
@ -192,30 +175,30 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
end if
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),val,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos)
#if defined(HAVE_SLU_)
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
end select
endif
@ -226,7 +209,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
case(mld_coarse_fillin_)
if (ilev_ /= nlev_) then
@ -235,9 +218,9 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
case default
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end select
endif
@ -248,33 +231,12 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
! levels
!
select case(what)
case(mld_sub_solve_)
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%precv(ilev_)%sm)) then
write(psb_err_unit,*) name,&
& ': Error: uninitialized preconditioner component,',&
& ' should call MLD_PRECINIT'
info = -1
return
endif
call onelev_set_solver(p%precv(ilev_),val,info)
end do
case(mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
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 p%precv(ilev_)%set(what,val,info)
end do
case(mld_smoother_sweeps_)
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_smoother_type_)
do ilev_=1,max(1,nlev_-1)
call onelev_set_smoother(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,&
@ -282,336 +244,73 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
& mld_smoother_pos_,mld_aggr_omega_alg_,&
& mld_aggr_eig_,mld_aggr_filter_)
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
case(mld_coarse_mat_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_mat_,val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos)
end if
case(mld_coarse_solve_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
#if defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
#elif defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
#if defined(HAVE_SLU_)
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
end select
endif
case(mld_coarse_subsolve_)
if (nlev_ > 1) then
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
endif
case(mld_coarse_sweeps_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
end if
case(mld_coarse_fillin_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
end if
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select
endif
contains
subroutine onelev_set_smoother(level,val,info)
type(mld_s_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_noprec_)
if (allocated(level%sm)) then
select type (sm => level%sm)
type is (mld_s_base_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_s_base_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_s_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_base_smoother_type ::&
& level%sm, stat=info)
if (info ==0) allocate(mld_s_id_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_jac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_s_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_s_jac_smoother_type :: &
& level%sm, stat=info)
if (info == 0) allocate(mld_s_diag_solver_type :: &
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_s_diag_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_bjac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_s_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_s_jac_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_as_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_s_as_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_s_as_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_as_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(level%sm)) &
& call level%sm%default()
end subroutine onelev_set_smoother
subroutine onelev_set_solver(level,val,info)
type(mld_s_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_f_none_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_id_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_id_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_diag_scale_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_diag_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_diag_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_diag_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_gs_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_gs_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_gs_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_gs_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_ilu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_ilu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
call level%sm%sv%set(mld_sub_solve_,val,info)
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#ifdef HAVE_SLU_
case (mld_slu_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_slu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_slu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_slu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_s_mumps_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_s_mumps_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_s_mumps_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
end if
end if
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
end subroutine onelev_set_solver
end subroutine mld_sprecseti
subroutine mld_sprecsetsm(p,val,info,ilev)
subroutine mld_sprecsetsm(p,val,info,ilev,pos)
use psb_base_mod
use mld_s_prec_mod, mld_protect_name => mld_sprecsetsm
@ -623,6 +322,7 @@ subroutine mld_sprecsetsm(p,val,info,ilev)
class(mld_s_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
@ -658,23 +358,13 @@ subroutine mld_sprecsetsm(p,val,info,ilev)
do ilev_ = ilmin, ilmax
if (allocated(p%precv(ilev_)%sm)) then
if (allocated(p%precv(ilev_)%sm%sv)) then
deallocate(p%precv(ilev_)%sm%sv)
endif
deallocate(p%precv(ilev_)%sm)
end if
#ifdef HAVE_MOLD
allocate(p%precv(ilev_)%sm,mold=val)
#else
allocate(p%precv(ilev_)%sm,source=val)
#endif
call p%precv(ilev_)%sm%default()
call p%precv(ilev_)%set(val,info,pos=pos)
if (info /= 0) return
end do
end subroutine mld_sprecsetsm
subroutine mld_sprecsetsv(p,val,info,ilev)
subroutine mld_sprecsetsv(p,val,info,ilev,pos)
use psb_base_mod
use mld_s_prec_mod, mld_protect_name => mld_sprecsetsv
@ -686,6 +376,7 @@ subroutine mld_sprecsetsv(p,val,info,ilev)
class(mld_s_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
@ -720,43 +411,11 @@ subroutine mld_sprecsetsv(p,val,info,ilev)
return
endif
do ilev_ = ilmin, ilmax
if (allocated(p%precv(ilev_)%sm)) then
if (allocated(p%precv(ilev_)%sm%sv)) then
if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then
deallocate(p%precv(ilev_)%sm%sv,stat=info)
if (info /= 0) then
info = 3111
return
end if
end if
if (.not.allocated(p%precv(ilev_)%sm%sv)) then
#ifdef HAVE_MOLD
allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info)
#else
allocate(p%precv(ilev_)%sm%sv,source=val,stat=info)
#endif
if (info /= 0) then
info = 3111
return
end if
end if
end if
call p%precv(ilev_)%sm%sv%default()
else
info = 3111
write(psb_err_unit,*) name,&
&': Error: uninitialized preconditioner component,',&
&' should call MLD_PRECINIT/MLD_PRECSET'
return
end if
call p%precv(ilev_)%set(val,info,pos=pos)
if (info /= 0) return
end do
end subroutine mld_sprecsetsv
!
@ -798,7 +457,7 @@ end subroutine mld_sprecsetsv
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_sprecsetc(p,what,string,info,ilev)
subroutine mld_sprecsetc(p,what,string,info,ilev,pos)
use psb_base_mod
use mld_s_prec_mod, mld_protect_name => mld_sprecsetc
@ -811,6 +470,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev)
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_,val
@ -838,7 +498,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev)
endif
val = mld_stringval(string)
if (val >=0) call p%set(what,val,info,ilev=ilev)
if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos)
end subroutine mld_sprecsetc
@ -882,7 +542,7 @@ end subroutine mld_sprecsetc
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_sprecsetr(p,what,val,info,ilev)
subroutine mld_sprecsetr(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_s_prec_mod, mld_protect_name => mld_sprecsetr
@ -895,6 +555,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_,nlev_
@ -931,7 +592,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
!
if (present(ilev)) then
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (.not.present(ilev)) then
!
@ -941,19 +602,19 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
select case(what)
case(mld_coarse_iluthrs_)
ilev_=nlev_
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info)
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos)
case(mld_aggr_thresh_)
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select

501
mlprec/impl/mld_zcprecset.F90
Unescape Escape View File

@ -76,7 +76,7 @@
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_zcprecseti(p,what,val,info,ilev)
subroutine mld_zcprecseti(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_z_prec_mod, mld_protect_name => mld_zcprecseti
@ -108,6 +108,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_
@ -150,38 +151,20 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
!
! Rules for fine level are slightly different.
!
select case(psb_toupper(trim(what)))
case('SMOOTHER_TYPE')
call onelev_set_smoother(p%precv(ilev_),val,info)
case('SUB_SOLVE')
call onelev_set_solver(p%precv(ilev_),val,info)
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
call p%precv(ilev_)%set(what,val,info)
case default
call p%precv(ilev_)%set(what,val,info)
end select
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (ilev_ > 1) then
select case(psb_toupper(what))
case('SMOOTHER_TYPE')
call onelev_set_smoother(p%precv(ilev_),val,info)
case('SUB_SOLVE')
call onelev_set_solver(p%precv(ilev_),val,info)
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
& 'SMOOTHER_SWEEPS_POST',&
& 'SUB_RESTR','SUB_PROL', &
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
& 'COARSE_MAT')
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
case('COARSE_SUBSOLVE')
if (ilev_ /= nlev_) then
@ -190,7 +173,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
info = -2
return
end if
call onelev_set_solver(p%precv(ilev_),val,info)
call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos)
case('COARSE_SOLVE')
if (ilev_ /= nlev_) then
write(psb_err_unit,*) name,&
@ -198,40 +181,36 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
info = -2
return
end if
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
#if defined(HAVE_UMF_)
call onelev_set_solver(p%precv(nlev_),mld_umf_,info)
#elif defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
#elif defined(HAVE_SLU_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
end select
endif
case('COARSE_SWEEPS')
if (ilev_ /= nlev_) then
@ -240,7 +219,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
case('COARSE_FILLIN')
if (ilev_ /= nlev_) then
@ -249,9 +228,10 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
case default
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end select
endif
@ -262,33 +242,12 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
! levels
!
select case(psb_toupper(trim(what)))
case('SUB_SOLVE')
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%precv(ilev_)%sm)) then
write(psb_err_unit,*) name,&
& ': Error: uninitialized preconditioner component,',&
& ' should call MLD_PRECINIT'
info = -1
return
endif
call onelev_set_solver(p%precv(ilev_),val,info)
end do
case('SUB_RESTR','SUB_PROL',&
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
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)
end do
case('SMOOTHER_SWEEPS')
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case('SMOOTHER_TYPE')
do ilev_=1,max(1,nlev_-1)
call onelev_set_smoother(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
@ -296,386 +255,70 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
& 'AGGR_EIG','AGGR_FILTER')
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case('COARSE_MAT')
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_MAT',val,info)
call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos)
end if
case('COARSE_SOLVE')
if (nlev_ > 1) then
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
#if defined(HAVE_UMF_)
call onelev_set_solver(p%precv(nlev_),mld_umf_,info)
#elif defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
#elif defined(HAVE_SLU_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
end select
endif
case('COARSE_SUBSOLVE')
if (nlev_ > 1) then
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
endif
case('COARSE_SWEEPS')
if (nlev_ > 1) then
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
end if
case('COARSE_FILLIN')
if (nlev_ > 1) then
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
end if
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select
endif
contains
subroutine onelev_set_smoother(level,val,info)
type(mld_z_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_noprec_)
if (allocated(level%sm)) then
select type (sm => level%sm)
type is (mld_z_base_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_z_base_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_z_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_base_smoother_type ::&
& level%sm, stat=info)
if (info ==0) allocate(mld_z_id_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_jac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_z_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_z_jac_smoother_type :: &
& level%sm, stat=info)
if (info == 0) allocate(mld_z_diag_solver_type :: &
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_z_diag_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_bjac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_z_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_z_jac_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_as_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_z_as_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_z_as_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_as_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(level%sm)) &
& call level%sm%default()
end subroutine onelev_set_smoother
subroutine onelev_set_solver(level,val,info)
type(mld_z_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_f_none_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_id_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_id_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_diag_scale_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_diag_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_diag_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_diag_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_gs_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_gs_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_gs_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_gs_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
else
endif
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_ilu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_ilu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
call level%sm%sv%set('SUB_SOLVE',val,info)
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#ifdef HAVE_SLU_
case (mld_slu_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_slu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_slu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_slu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_mumps_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_mumps_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_mumps_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
#endif
#ifdef HAVE_UMF_
case (mld_umf_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_umf_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_umf_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_umf_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_sludist_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_sludist_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_sludist_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
end subroutine onelev_set_solver
end subroutine mld_zcprecseti
!
@ -717,7 +360,7 @@ end subroutine mld_zcprecseti
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_zcprecsetc(p,what,string,info,ilev)
subroutine mld_zcprecsetc(p,what,string,info,ilev,pos)
use psb_base_mod
use mld_z_prec_mod, mld_protect_name => mld_zcprecsetc
@ -730,6 +373,7 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev)
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_,val
@ -758,9 +402,9 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev)
val = mld_stringval(string)
if (val >=0) then
call p%set(what,val,info,ilev=ilev)
call p%set(what,val,info,ilev=ilev,pos=pos)
else
call p%precv(ilev_)%set(what,string,info)
call p%precv(ilev_)%set(what,string,info,pos=pos)
end if
end subroutine mld_zcprecsetc
@ -804,7 +448,7 @@ end subroutine mld_zcprecsetc
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_zcprecsetr(p,what,val,info,ilev)
subroutine mld_zcprecsetr(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_z_prec_mod, mld_protect_name => mld_zcprecsetr
@ -817,6 +461,7 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev)
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_,nlev_
@ -853,7 +498,7 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev)
!
if (present(ilev)) then
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (.not.present(ilev)) then
!
@ -863,19 +508,19 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev)
select case(psb_toupper(what))
case('COARSE_ILUTHRS')
ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info)
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_THRESH')
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_THRESH',thr,info)
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select

134
mlprec/impl/mld_zmlprec_aply.f90
Unescape Escape View File

@ -405,10 +405,10 @@ contains
implicit none
! Arguments
integer(psb_ipk_) :: level
type(mld_zprec_type), intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
integer(psb_ipk_) :: level
type(mld_zprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
@ -434,7 +434,6 @@ contains
ictxt = p%precv(level)%base_desc%get_context()
call psb_info(ictxt, me, np)
if (level > 1) then
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
@ -539,7 +538,6 @@ contains
end if
! This is one step of post-smoothing
if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then
@ -572,7 +570,7 @@ contains
end if
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(zone,&
call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%x2l,zone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
@ -621,13 +619,17 @@ contains
!
if (level < nlev) then
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -830,6 +832,13 @@ contains
case(mld_twoside_smooth_)
! CHECK
if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then
write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999
end if
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info)
@ -866,10 +875,19 @@ contains
else
sweeps = p%precv(level)%parms%sweeps
end if
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
@ -930,10 +948,18 @@ contains
else
sweeps = p%precv(level)%parms%sweeps_pre
end if
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
@ -1043,7 +1069,7 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
level = 1
call psb_geaxpby(zone,x,zzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info)
call mlprec_wrk(level)%vy2l%set(zzero)
call mlprec_wrk(level)%vy2l%zero()
call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info)
@ -1090,12 +1116,12 @@ contains
implicit none
! Arguments
integer(psb_ipk_) :: level
type(mld_zprec_type), intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: level
type(mld_zprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: ictxt,np,me
@ -1122,7 +1148,9 @@ contains
nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows()
if(debug_level > 1) then
write(debug_unit,*) me,' inner_ml_aply at level ',level
end if
select case(p%precv(level)%parms%ml_type)
@ -1160,7 +1188,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during ADD smoother_apply')
goto 9999
end if
@ -1250,25 +1278,25 @@ contains
sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(zone,&
call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%vx2l,zone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
else
sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(zone,&
call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
@ -1302,13 +1330,13 @@ contains
else
sweeps = p%precv(level)%parms%sweeps
end if
call p%precv(level)%sm%apply(zone,&
call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during POST smoother_apply')
goto 9999
end if
@ -1386,7 +1414,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during PRE smoother_apply')
goto 9999
end if
@ -1484,7 +1512,7 @@ contains
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during PRE smoother_apply')
goto 9999
end if
else
@ -1530,19 +1558,28 @@ contains
if (level < nlev) then
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
else
sweeps = p%precv(level)%parms%sweeps
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during 2-PRE smoother_apply')
goto 9999
end if
@ -1602,16 +1639,21 @@ contains
!
if (trans == 'N') then
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
& a_err='Error during 2-POST smoother_apply')
goto 9999
end if

12
mlprec/impl/mld_zmlprec_bld.f90
Unescape Escape View File

@ -495,10 +495,16 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold)
if ((info == psb_success_).and.(i>1)) then
call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
if (info == 0) then
if (allocated(p%precv(i)%sm2a)) then
call p%precv(i)%sm2a%build(a,desc_a,upd_,info,&
& amold=amold,vmold=vmold,imold=imold)
p%precv(i)%sm2 => p%precv(i)%sm2a
else
p%precv(i)%sm2 => p%precv(i)%sm
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='One level preconditioner build.')

535
mlprec/impl/mld_zprecset.F90
Unescape Escape View File

@ -76,7 +76,7 @@
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_zprecseti(p,what,val,info,ilev)
subroutine mld_zprecseti(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_z_prec_mod, mld_protect_name => mld_zprecseti
@ -107,6 +107,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_
@ -147,39 +148,21 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
if (present(ilev)) then
if (ilev_ == 1) then
!
! Rules for fine level are slightly different.
!
select case(what)
case(mld_smoother_type_)
call onelev_set_smoother(p%precv(ilev_),val,info)
case(mld_sub_solve_)
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
call p%precv(ilev_)%set(what,val,info)
case default
call p%precv(ilev_)%set(what,val,info)
end select
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (ilev_ > 1) then
select case(what)
case(mld_smoother_type_)
call onelev_set_smoother(p%precv(ilev_),val,info)
case(mld_sub_solve_)
call onelev_set_solver(p%precv(ilev_),val,info)
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
& mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
& mld_aggr_kind_,mld_smoother_pos_,&
& mld_aggr_omega_alg_,mld_aggr_eig_,&
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
& mld_sub_restr_,mld_sub_prol_, &
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_coarse_mat_)
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
case(mld_coarse_subsolve_)
if (ilev_ /= nlev_) then
@ -188,7 +171,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
info = -2
return
end if
call onelev_set_solver(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos)
case(mld_coarse_solve_)
if (ilev_ /= nlev_) then
write(psb_err_unit,*) name,&
@ -198,32 +181,32 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
end if
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos)
#if defined(HAVE_UMF_)
call onelev_set_solver(p%precv(nlev_),mld_umf_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos)
#elif defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
#elif defined(HAVE_MUMPS_)
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_,mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
end select
endif
@ -234,7 +217,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
case(mld_coarse_fillin_)
if (ilev_ /= nlev_) then
@ -243,9 +226,9 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
info = -2
return
end if
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
case default
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end select
endif
@ -256,33 +239,12 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
! levels
!
select case(what)
case(mld_sub_solve_)
case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_,mld_smoother_type_)
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%precv(ilev_)%sm)) then
write(psb_err_unit,*) name,&
& ': Error: uninitialized preconditioner component,',&
& ' should call MLD_PRECINIT'
info = -1
return
endif
call onelev_set_solver(p%precv(ilev_),val,info)
end do
case(mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_smoother_sweeps_)
do ilev_=1,max(1,nlev_-1)
call p%precv(ilev_)%set(what,val,info)
end do
case(mld_smoother_type_)
do ilev_=1,max(1,nlev_-1)
call onelev_set_smoother(p%precv(ilev_),val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
if (info /= 0) return
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,&
@ -290,386 +252,75 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
& mld_smoother_pos_,mld_aggr_omega_alg_,&
& mld_aggr_eig_,mld_aggr_filter_)
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
case(mld_coarse_mat_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_mat_,val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos)
end if
case(mld_coarse_solve_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
select case (val)
case(mld_bjac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
#if defined(HAVE_UMF_)
call onelev_set_solver(p%precv(nlev_),mld_umf_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos)
#elif defined(HAVE_SLU_)
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
#else
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
#endif
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
case(mld_sludist_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_mumps_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
case(mld_jac_)
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
end select
endif
case(mld_coarse_subsolve_)
if (nlev_ > 1) then
call onelev_set_solver(p%precv(nlev_),val,info)
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
endif
case(mld_coarse_sweeps_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
end if
case(mld_coarse_fillin_)
if (nlev_ > 1) then
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
end if
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select
endif
contains
subroutine onelev_set_smoother(level,val,info)
type(mld_z_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_noprec_)
if (allocated(level%sm)) then
select type (sm => level%sm)
type is (mld_z_base_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_z_base_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_z_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_base_smoother_type ::&
& level%sm, stat=info)
if (info ==0) allocate(mld_z_id_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_jac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_z_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_z_jac_smoother_type :: &
& level%sm, stat=info)
if (info == 0) allocate(mld_z_diag_solver_type :: &
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_z_diag_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_bjac_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_z_jac_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_z_jac_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_jac_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case (mld_as_)
if (allocated(level%sm)) then
select type (sm => level%sm)
class is (mld_z_as_smoother_type)
! do nothing
class default
call level%sm%free(info)
if (info == 0) deallocate(level%sm)
if (info == 0) allocate(mld_z_as_smoother_type ::&
& level%sm, stat=info)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_as_smoother_type :: level%sm, stat=info)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
endif
case default
!
! Do nothing and hope for the best :)
!
end select
if (allocated(level%sm)) &
& call level%sm%default()
end subroutine onelev_set_smoother
subroutine onelev_set_solver(level,val,info)
type(mld_z_onelev_type), intent(inout) :: level
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
! This here requires a bit more attention.
!
select case (val)
case (mld_f_none_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_id_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_id_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_id_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_diag_scale_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_diag_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_diag_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_diag_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_gs_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_gs_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_gs_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_gs_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_ilu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_ilu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_ilu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
call level%sm%sv%set(mld_sub_solve_,val,info)
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#ifdef HAVE_UMF_
case (mld_umf_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_umf_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_umf_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_umf_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_SLUDIST_
case (mld_sludist_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_sludist_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_sludist_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_sludist_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_SLU_
case (mld_slu_)
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_slu_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_slu_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_slu_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) &
& call level%sm%sv%default()
end if
else
write(0,*) 'Calling set_solver without a smoother?'
info = -5
end if
#endif
#ifdef HAVE_MUMPS_
case (mld_mumps_)
if (allocated(level%sm%sv)) then
select type (sv => level%sm%sv)
class is (mld_z_mumps_solver_type)
! do nothing
class default
call level%sm%sv%free(info)
if (info == 0) deallocate(level%sm%sv)
if (info == 0) allocate(mld_z_mumps_solver_type ::&
& level%sm%sv, stat=info)
end select
else
allocate(mld_z_mumps_solver_type :: level%sm%sv, stat=info)
endif
if (allocated(level%sm)) then
if (allocated(level%sm%sv)) then
call level%sm%sv%default()
end if
end if
#endif
case default
!
! Do nothing and hope for the best :)
!
end select
end subroutine onelev_set_solver
end subroutine mld_zprecseti
subroutine mld_zprecsetsm(p,val,info,ilev)
subroutine mld_zprecsetsm(p,val,info,ilev,pos)
use psb_base_mod
use mld_z_prec_mod, mld_protect_name => mld_zprecsetsm
@ -681,6 +332,7 @@ subroutine mld_zprecsetsm(p,val,info,ilev)
class(mld_z_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
@ -716,23 +368,13 @@ subroutine mld_zprecsetsm(p,val,info,ilev)
do ilev_ = ilmin, ilmax
if (allocated(p%precv(ilev_)%sm)) then
if (allocated(p%precv(ilev_)%sm%sv)) then
deallocate(p%precv(ilev_)%sm%sv)
endif
deallocate(p%precv(ilev_)%sm)
end if
#ifdef HAVE_MOLD
allocate(p%precv(ilev_)%sm,mold=val)
#else
allocate(p%precv(ilev_)%sm,source=val)
#endif
call p%precv(ilev_)%sm%default()
call p%precv(ilev_)%set(val,info,pos=pos)
if (info /= 0) return
end do
end subroutine mld_zprecsetsm
subroutine mld_zprecsetsv(p,val,info,ilev)
subroutine mld_zprecsetsv(p,val,info,ilev,pos)
use psb_base_mod
use mld_z_prec_mod, mld_protect_name => mld_zprecsetsv
@ -744,6 +386,7 @@ subroutine mld_zprecsetsv(p,val,info,ilev)
class(mld_z_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
@ -778,43 +421,11 @@ subroutine mld_zprecsetsv(p,val,info,ilev)
return
endif
do ilev_ = ilmin, ilmax
if (allocated(p%precv(ilev_)%sm)) then
if (allocated(p%precv(ilev_)%sm%sv)) then
if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then
deallocate(p%precv(ilev_)%sm%sv,stat=info)
if (info /= 0) then
info = 3111
return
end if
end if
if (.not.allocated(p%precv(ilev_)%sm%sv)) then
#ifdef HAVE_MOLD
allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info)
#else
allocate(p%precv(ilev_)%sm%sv,source=val,stat=info)
#endif
if (info /= 0) then
info = 3111
return
end if
end if
end if
call p%precv(ilev_)%sm%sv%default()
else
info = 3111
write(psb_err_unit,*) name,&
&': Error: uninitialized preconditioner component,',&
&' should call MLD_PRECINIT/MLD_PRECSET'
return
end if
call p%precv(ilev_)%set(val,info,pos=pos)
if (info /= 0) return
end do
end subroutine mld_zprecsetsv
!
@ -856,7 +467,7 @@ end subroutine mld_zprecsetsv
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_zprecsetc(p,what,string,info,ilev)
subroutine mld_zprecsetc(p,what,string,info,ilev,pos)
use psb_base_mod
use mld_z_prec_mod, mld_protect_name => mld_zprecsetc
@ -869,6 +480,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev)
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_, nlev_,val
@ -896,7 +508,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev)
endif
val = mld_stringval(string)
if (val >=0) call p%set(what,val,info,ilev=ilev)
if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos)
end subroutine mld_zprecsetc
@ -940,7 +552,7 @@ end subroutine mld_zprecsetc
! For this reason, the interface mld_precset to this routine has been built in
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
!
subroutine mld_zprecsetr(p,what,val,info,ilev)
subroutine mld_zprecsetr(p,what,val,info,ilev,pos)
use psb_base_mod
use mld_z_prec_mod, mld_protect_name => mld_zprecsetr
@ -953,6 +565,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
! Local variables
integer(psb_ipk_) :: ilev_,nlev_
@ -989,7 +602,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
!
if (present(ilev)) then
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
else if (.not.present(ilev)) then
!
@ -999,19 +612,19 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
select case(what)
case(mld_coarse_iluthrs_)
ilev_=nlev_
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info)
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos)
case(mld_aggr_thresh_)
thr = val
do ilev_ = 2, nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos)
thr = thr * p%precv(ilev_)%parms%aggr_scale
end do
case default
do ilev_=1,nlev_
call p%precv(ilev_)%set(what,val,info)
call p%precv(ilev_)%set(what,val,info,pos=pos)
end do
end select

9
mlprec/impl/solver/Makefile
Unescape Escape View File

@ -34,6 +34,9 @@ mld_c_gs_solver_cnv.o \
mld_c_gs_solver_dmp.o \
mld_c_gs_solver_apply.o \
mld_c_gs_solver_apply_vect.o \
mld_c_bwgs_solver_bld.o \
mld_c_bwgs_solver_apply.o \
mld_c_bwgs_solver_apply_vect.o \
mld_c_id_solver_apply.o \
mld_c_id_solver_apply_vect.o \
mld_c_id_solver_clone.o \
@ -113,6 +116,9 @@ mld_s_gs_solver_cnv.o \
mld_s_gs_solver_dmp.o \
mld_s_gs_solver_apply.o \
mld_s_gs_solver_apply_vect.o \
mld_s_bwgs_solver_bld.o \
mld_s_bwgs_solver_apply.o \
mld_s_bwgs_solver_apply_vect.o \
mld_s_id_solver_apply.o \
mld_s_id_solver_apply_vect.o \
mld_s_id_solver_clone.o \
@ -151,6 +157,9 @@ mld_z_gs_solver_cnv.o \
mld_z_gs_solver_dmp.o \
mld_z_gs_solver_apply.o \
mld_z_gs_solver_apply_vect.o \
mld_z_bwgs_solver_bld.o \
mld_z_bwgs_solver_apply.o \
mld_z_bwgs_solver_apply_vect.o \
mld_z_id_solver_apply.o \
mld_z_id_solver_apply_vect.o \
mld_z_id_solver_clone.o \

196
mlprec/impl/solver/mld_c_bwgs_solver_apply.f90
Unescape Escape View File

@ -0,0 +1,196 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_c_bwgs_solver_type), intent(inout) :: sv
complex(psb_spk_),intent(inout) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: n_row,n_col, itx
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
complex(psb_spk_), allocatable :: temp(:),wv(:),xit(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_bwgs_solver_apply'
call psb_erractionsave(err_act)
ictxt = desc_data%get_ctxt()
call psb_info(ictxt,me,np)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
!!$ case('T')
!!$ case('C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols()
if (n_col <= size(work)) then
ww => work(1:n_col)
if ((4*n_col+n_col) <= size(work)) then
aux => work(n_col+1:)
else
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
endif
else
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
endif
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
call psb_geasb(wv,desc_data,info)
call psb_geasb(xit,desc_data,info)
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
! WARNING: this is not completely satisfactory. We are assuming here Y
! as the initial guess, but this is only working if we are called from the
! current JAC smoother loop. A good solution would be to have a separate
! input argument as the initial guess
!
!!$ write(0,*) 'GS Iteration with ',sv%sweeps
call psb_geaxpby(cone,y,czero,xit,desc_data,info)
do itx=1,sv%sweeps
call psb_geaxpby(cone,x,czero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-cone,sv%l,xit,cone,wv,desc_data,info,doswap=.false.)
call psb_spsm(cone,sv%u,wv,czero,xit,desc_data,info)
!!$ temp = xit%get_vect()
!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else
deallocate(aux)
endif
else
deallocate(ww,aux)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_c_bwgs_solver_apply

200
mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90
Unescape Escape View File

@ -0,0 +1,200 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_c_bwgs_solver_type), intent(inout) :: sv
type(psb_c_vect_type),intent(inout) :: x
type(psb_c_vect_type),intent(inout) :: y
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_c_vect_type) :: wv, xit
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
complex(psb_spk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_bwgs_solver_apply'
call psb_erractionsave(err_act)
ictxt = desc_data%get_ctxt()
call psb_info(ictxt,me,np)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
!!$ case('T')
!!$ case('C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols()
if (x%get_nrows() < n_row) then
info = 36
call psb_errpush(info,name,&
& i_err=(/itwo,n_row,izero,izero,izero/))
goto 9999
end if
if (y%get_nrows() < n_row) then
info = 36
call psb_errpush(info,name,&
& i_err=(/ithree,n_row,izero,izero,izero/))
goto 9999
end if
if (n_col <= size(work)) then
ww => work(1:n_col)
if ((4*n_col+n_col) <= size(work)) then
aux => work(n_col+1:)
else
allocate(aux(4*n_col),stat=info)
endif
else
allocate(ww(n_col),aux(4*n_col),stat=info)
endif
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
! WARNING: this is not completely satisfactory. We are assuming here Y
! as the initial guess, but this is only working if we are called from the
! current JAC smoother loop. A good solution would be to have a separate
! input argument as the initial guess
!
!!$ write(0,*) 'GS Iteration with ',sv%sweeps
call psb_geaxpby(cone,y,czero,xit,desc_data,info)
do itx=1,sv%sweeps
call psb_geaxpby(cone,x,czero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-cone,sv%l,xit,cone,wv,desc_data,info,doswap=.false.)
call psb_spsm(cone,sv%u,wv,czero,xit,desc_data,info)
!!$ temp = xit%get_vect()
!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else
deallocate(aux)
endif
else
deallocate(ww,aux)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_c_bwgs_solver_apply_vect

117
mlprec/impl/solver/mld_c_bwgs_solver_bld.f90
Unescape Escape View File

@ -0,0 +1,117 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold)
use psb_base_mod
use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_bld
Implicit None
! Arguments
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_c_bwgs_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
type(psb_cspmat_type), intent(in), target, optional :: b
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
! Local variables
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_bwgs_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
n_row = desc_a%get_local_rows()
if (psb_toupper(upd) == 'F') then
nrow_a = a%get_nrows()
nztota = a%get_nzeros()
!!$ if (present(b)) then
!!$ nztota = nztota + b%get_nzeros()
!!$ end if
if (sv%eps <= dzero) then
!
! This cuts out the off-diagonal part, because it's supposed to
! be handled by the outer Jacobi smoother.
!
call a%tril(sv%l,info,diag=-1)
call a%triu(sv%u,info,jmax=nrow_a)
else
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
end if
call sv%l%set_asb()
call sv%l%trim()
call sv%u%set_asb()
call sv%u%trim()
if (present(amold)) then
call sv%l%cscnv(info,mold=amold)
call sv%u%cscnv(info,mold=amold)
end if
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_c_bwgs_solver_bld

17
mlprec/impl/solver/mld_d_mumps_solver_apply.F90
Unescape Escape View File

@ -58,10 +58,9 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
character :: trans_
character(len=20) :: name='d_mumps_solver_apply'
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
#if defined(HAVE_MUMPS_)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
@ -106,13 +105,13 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
goto 9999
end select
sv%id%rhs => gx
sv%id%nrhs = 1
sv%id%icntl(1) = -1
sv%id%icntl(2) = -1
sv%id%icntl(3) = -1
sv%id%icntl(4) = -1
sv%id%job = 3
sv%id%rhs => gx
sv%id%nrhs = 1
sv%id%icntl(1)=-1
sv%id%icntl(2)=-1
sv%id%icntl(3)=-1
sv%id%icntl(4)=-1
sv%id%job = 3
call dmumps(sv%id)
call psb_scatter(gx, ww, desc_data, info, root=0)

1
mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90
Unescape Escape View File

@ -79,5 +79,6 @@
#else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif
end subroutine d_mumps_solver_apply_vect

16
mlprec/impl/solver/mld_d_mumps_solver_bld.F90
Unescape Escape View File

@ -106,8 +106,8 @@
if (psb_toupper(upd) == 'F') then
sv%id%comm = icomm
sv%id%job = -1
sv%id%par = 1
sv%id%job = -1
sv%id%par=1
call dmumps(sv%id)
!WARNING: CALLING dMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX
sv%id%icntl(3)=sv%ipar(2)
@ -115,7 +115,7 @@
if (sv%ipar(1) < 0) then
nglobrec=desc_a%get_local_rows()
call a%csclip(c,info,jmax=a%get_nrows())
call c%mv_to(acoo)
call c%cp_to(acoo)
nglob = c%get_nrows()
if (nglobrec /= nglob) then
write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. A zero-overlap is used instead'
@ -130,10 +130,9 @@
call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I')
call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I')
end if
sv%id%irn_loc => acoo%ia
sv%id%jcn_loc => acoo%ja
sv%id%a_loc => acoo%val
sv%id%irn_loc=> acoo%ia
sv%id%jcn_loc=> acoo%ja
sv%id%a_loc=> acoo%val
sv%id%icntl(18)=3
if(acoo%is_upper() .or. acoo%is_lower()) then
sv%id%sym = 2
@ -144,7 +143,7 @@
! there should be a better way for this
sv%id%nz_loc = acoo%get_nzeros()
sv%id%nz = acoo%get_nzeros()
sv%id%job = 4
sv%id%job = 4
call psb_barrier(ictxt)
write(*,*)'calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc
call dmumps(sv%id)
@ -183,7 +182,6 @@
return
end if
return
#else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif

196
mlprec/impl/solver/mld_s_bwgs_solver_apply.f90
Unescape Escape View File

@ -0,0 +1,196 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_bwgs_solver_type), intent(inout) :: sv
real(psb_spk_),intent(inout) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: n_row,n_col, itx
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
real(psb_spk_), allocatable :: temp(:),wv(:),xit(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_bwgs_solver_apply'
call psb_erractionsave(err_act)
ictxt = desc_data%get_ctxt()
call psb_info(ictxt,me,np)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
!!$ case('T')
!!$ case('C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols()
if (n_col <= size(work)) then
ww => work(1:n_col)
if ((4*n_col+n_col) <= size(work)) then
aux => work(n_col+1:)
else
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
else
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
call psb_geasb(wv,desc_data,info)
call psb_geasb(xit,desc_data,info)
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
! WARNING: this is not completely satisfactory. We are assuming here Y
! as the initial guess, but this is only working if we are called from the
! current JAC smoother loop. A good solution would be to have a separate
! input argument as the initial guess
!
!!$ write(0,*) 'GS Iteration with ',sv%sweeps
call psb_geaxpby(sone,y,szero,xit,desc_data,info)
do itx=1,sv%sweeps
call psb_geaxpby(sone,x,szero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-sone,sv%l,xit,sone,wv,desc_data,info,doswap=.false.)
call psb_spsm(sone,sv%u,wv,szero,xit,desc_data,info)
!!$ temp = xit%get_vect()
!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else
deallocate(aux)
endif
else
deallocate(ww,aux)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_s_bwgs_solver_apply

200
mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90
Unescape Escape View File

@ -0,0 +1,200 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_bwgs_solver_type), intent(inout) :: sv
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_s_vect_type) :: wv, xit
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
real(psb_spk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_bwgs_solver_apply'
call psb_erractionsave(err_act)
ictxt = desc_data%get_ctxt()
call psb_info(ictxt,me,np)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
!!$ case('T')
!!$ case('C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols()
if (x%get_nrows() < n_row) then
info = 36
call psb_errpush(info,name,&
& i_err=(/itwo,n_row,izero,izero,izero/))
goto 9999
end if
if (y%get_nrows() < n_row) then
info = 36
call psb_errpush(info,name,&
& i_err=(/ithree,n_row,izero,izero,izero/))
goto 9999
end if
if (n_col <= size(work)) then
ww => work(1:n_col)
if ((4*n_col+n_col) <= size(work)) then
aux => work(n_col+1:)
else
allocate(aux(4*n_col),stat=info)
endif
else
allocate(ww(n_col),aux(4*n_col),stat=info)
endif
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
! WARNING: this is not completely satisfactory. We are assuming here Y
! as the initial guess, but this is only working if we are called from the
! current JAC smoother loop. A good solution would be to have a separate
! input argument as the initial guess
!
!!$ write(0,*) 'GS Iteration with ',sv%sweeps
call psb_geaxpby(sone,y,szero,xit,desc_data,info)
do itx=1,sv%sweeps
call psb_geaxpby(sone,x,szero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-sone,sv%l,xit,sone,wv,desc_data,info,doswap=.false.)
call psb_spsm(sone,sv%u,wv,szero,xit,desc_data,info)
!!$ temp = xit%get_vect()
!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else
deallocate(aux)
endif
else
deallocate(ww,aux)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_s_bwgs_solver_apply_vect

117
mlprec/impl/solver/mld_s_bwgs_solver_bld.f90
Unescape Escape View File

@ -0,0 +1,117 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold)
use psb_base_mod
use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_bld
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_bwgs_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
! Local variables
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_bwgs_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
n_row = desc_a%get_local_rows()
if (psb_toupper(upd) == 'F') then
nrow_a = a%get_nrows()
nztota = a%get_nzeros()
!!$ if (present(b)) then
!!$ nztota = nztota + b%get_nzeros()
!!$ end if
if (sv%eps <= dzero) then
!
! This cuts out the off-diagonal part, because it's supposed to
! be handled by the outer Jacobi smoother.
!
call a%tril(sv%l,info,diag=-1)
call a%triu(sv%u,info,jmax=nrow_a)
else
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
end if
call sv%l%set_asb()
call sv%l%trim()
call sv%u%set_asb()
call sv%u%trim()
if (present(amold)) then
call sv%l%cscnv(info,mold=amold)
call sv%u%cscnv(info,mold=amold)
end if
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_s_bwgs_solver_bld

13
mlprec/impl/solver/mld_s_mumps_solver_apply.F90
Unescape Escape View File

@ -49,19 +49,18 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer(psb_ipk_), intent(out) :: info
integer :: n_row, n_col, nglob
integer(psb_ipk_) :: n_row, n_col, nglob
real(psb_spk_), allocatable :: ww(:)
real(psb_spk_), allocatable, target :: gx(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='s_mumps_solver_apply'
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
#if defined(HAVE_MUMPS_)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
@ -83,7 +82,7 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),&
& a_err='complex(psb_spk_)')
& a_err='real(psb_spk_)')
goto 9999
end if
end if
@ -91,7 +90,7 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nglob,0,0,0,0/),&
& a_err='complex(psb_spk_)')
& a_err='real(psb_spk_)')
goto 9999
end if
call psb_gather(gx, x, desc_data, info, root=0)

6
mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90
Unescape Escape View File

@ -48,12 +48,13 @@
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer(psb_ipk_), intent(out) :: info
integer :: err_act
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_mumps_solver_apply_vect'
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
info = psb_success_
@ -78,5 +79,6 @@
#else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif
end subroutine s_mumps_solver_apply_vect

15
mlprec/impl/solver/mld_s_mumps_solver_bld.F90
Unescape Escape View File

@ -51,7 +51,7 @@
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_mumps_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
integer(psb_ipk_), intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
@ -59,9 +59,9 @@
! Local variables
type(psb_sspmat_type) :: atmp
type(psb_s_coo_sparse_mat), target :: acoo
integer :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc
integer :: ifrst, ibcheck
integer :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc
integer(psb_ipk_) :: ifrst, ibcheck
integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level
character(len=20) :: name='s_mumps_solver_bld', ch_err
#if defined(HAVE_MUMPS_)
@ -97,7 +97,7 @@
allocate(sv%id,stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name,a_err='mld_mumps_default')
call psb_errpush(info,name,a_err='mld_smumps_default')
goto 9999
end if
end if
@ -109,7 +109,7 @@
sv%id%job = -1
sv%id%par=1
call smumps(sv%id)
!WARNING: CALLING mumps WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX
!WARNING: CALLING sMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX
sv%id%icntl(3)=sv%ipar(2)
nglob = desc_a%get_global_rows()
if (sv%ipar(1) < 0) then
@ -151,7 +151,7 @@
info = sv%id%infog(1)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_mumps_fact '
ch_err='mld_smumps_fact '
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -182,7 +182,6 @@
return
end if
return
#else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif

196
mlprec/impl/solver/mld_z_bwgs_solver_apply.f90
Unescape Escape View File

@ -0,0 +1,196 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_z_bwgs_solver_type), intent(inout) :: sv
complex(psb_dpk_),intent(inout) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: n_row,n_col, itx
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
complex(psb_dpk_), allocatable :: temp(:),wv(:),xit(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_bwgs_solver_apply'
call psb_erractionsave(err_act)
ictxt = desc_data%get_ctxt()
call psb_info(ictxt,me,np)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
!!$ case('T')
!!$ case('C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols()
if (n_col <= size(work)) then
ww => work(1:n_col)
if ((4*n_col+n_col) <= size(work)) then
aux => work(n_col+1:)
else
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
endif
else
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
endif
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
call psb_geasb(wv,desc_data,info)
call psb_geasb(xit,desc_data,info)
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
! WARNING: this is not completely satisfactory. We are assuming here Y
! as the initial guess, but this is only working if we are called from the
! current JAC smoother loop. A good solution would be to have a separate
! input argument as the initial guess
!
!!$ write(0,*) 'GS Iteration with ',sv%sweeps
call psb_geaxpby(zone,y,zzero,xit,desc_data,info)
do itx=1,sv%sweeps
call psb_geaxpby(zone,x,zzero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-zone,sv%l,xit,zone,wv,desc_data,info,doswap=.false.)
call psb_spsm(zone,sv%u,wv,zzero,xit,desc_data,info)
!!$ temp = xit%get_vect()
!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else
deallocate(aux)
endif
else
deallocate(ww,aux)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_z_bwgs_solver_apply

200
mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90
Unescape Escape View File

@ -0,0 +1,200 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_z_bwgs_solver_type), intent(inout) :: sv
type(psb_z_vect_type),intent(inout) :: x
type(psb_z_vect_type),intent(inout) :: y
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_z_vect_type) :: wv, xit
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
complex(psb_dpk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_bwgs_solver_apply'
call psb_erractionsave(err_act)
ictxt = desc_data%get_ctxt()
call psb_info(ictxt,me,np)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
!!$ case('T')
!!$ case('C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols()
if (x%get_nrows() < n_row) then
info = 36
call psb_errpush(info,name,&
& i_err=(/itwo,n_row,izero,izero,izero/))
goto 9999
end if
if (y%get_nrows() < n_row) then
info = 36
call psb_errpush(info,name,&
& i_err=(/ithree,n_row,izero,izero,izero/))
goto 9999
end if
if (n_col <= size(work)) then
ww => work(1:n_col)
if ((4*n_col+n_col) <= size(work)) then
aux => work(n_col+1:)
else
allocate(aux(4*n_col),stat=info)
endif
else
allocate(ww(n_col),aux(4*n_col),stat=info)
endif
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
! WARNING: this is not completely satisfactory. We are assuming here Y
! as the initial guess, but this is only working if we are called from the
! current JAC smoother loop. A good solution would be to have a separate
! input argument as the initial guess
!
!!$ write(0,*) 'GS Iteration with ',sv%sweeps
call psb_geaxpby(zone,y,zzero,xit,desc_data,info)
do itx=1,sv%sweeps
call psb_geaxpby(zone,x,zzero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-zone,sv%l,xit,zone,wv,desc_data,info,doswap=.false.)
call psb_spsm(zone,sv%u,wv,zzero,xit,desc_data,info)
!!$ temp = xit%get_vect()
!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else
deallocate(aux)
endif
else
deallocate(ww,aux)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_z_bwgs_solver_apply_vect

117
mlprec/impl/solver/mld_z_bwgs_solver_bld.f90
Unescape Escape View File

@ -0,0 +1,117 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold)
use psb_base_mod
use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_bld
Implicit None
! Arguments
type(psb_zspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_z_bwgs_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
type(psb_zspmat_type), intent(in), target, optional :: b
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
! Local variables
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_bwgs_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
n_row = desc_a%get_local_rows()
if (psb_toupper(upd) == 'F') then
nrow_a = a%get_nrows()
nztota = a%get_nzeros()
!!$ if (present(b)) then
!!$ nztota = nztota + b%get_nzeros()
!!$ end if
if (sv%eps <= dzero) then
!
! This cuts out the off-diagonal part, because it's supposed to
! be handled by the outer Jacobi smoother.
!
call a%tril(sv%l,info,diag=-1)
call a%triu(sv%u,info,jmax=nrow_a)
else
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
end if
call sv%l%set_asb()
call sv%l%trim()
call sv%u%set_asb()
call sv%u%trim()
if (present(amold)) then
call sv%l%cscnv(info,mold=amold)
call sv%u%cscnv(info,mold=amold)
end if
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_z_bwgs_solver_bld

8
mlprec/impl/solver/mld_z_mumps_solver_apply.F90
Unescape Escape View File

@ -58,10 +58,9 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
character :: trans_
character(len=20) :: name='z_mumps_solver_apply'
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
#if defined(HAVE_MUMPS_)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
@ -83,7 +82,7 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),&
& a_err='complex(psb_spk_)')
& a_err='complex(psb_dpk_)')
goto 9999
end if
end if
@ -91,7 +90,7 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nglob,0,0,0,0/),&
& a_err='complex(psb_spk_)')
& a_err='complex(psb_dpk_)')
goto 9999
end if
call psb_gather(gx, x, desc_data, info, root=0)
@ -144,6 +143,5 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
#else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif
end subroutine z_mumps_solver_apply

1
mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90
Unescape Escape View File

@ -79,5 +79,6 @@
#else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif
end subroutine z_mumps_solver_apply_vect

1
mlprec/impl/solver/mld_z_mumps_solver_bld.F90
Unescape Escape View File

@ -182,7 +182,6 @@
return
end if
return
#else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif

90
mlprec/mld_base_prec_type.F90
Unescape Escape View File

@ -179,28 +179,29 @@ module mld_base_prec_type
!
! Legal values for entry: mld_sub_solve_
!
integer(psb_ipk_), parameter :: mld_slv_delta_ = mld_max_prec_+1
integer(psb_ipk_), parameter :: mld_f_none_ = mld_slv_delta_+0
integer(psb_ipk_), parameter :: mld_diag_scale_ = mld_slv_delta_+1
integer(psb_ipk_), parameter :: mld_gs_ = mld_slv_delta_+2
integer(psb_ipk_), parameter :: mld_ilu_n_ = mld_slv_delta_+3
integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+4
integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+5
integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+6
integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+7
integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+8
integer(psb_ipk_), parameter :: mld_mumps_ = mld_slv_delta_+9
integer(psb_ipk_), parameter :: mld_max_sub_solve_= mld_slv_delta_+9
integer(psb_ipk_), parameter :: mld_min_sub_solve_= mld_diag_scale_
integer(psb_ipk_), parameter :: mld_slv_delta_ = mld_max_prec_+1
integer(psb_ipk_), parameter :: mld_f_none_ = mld_slv_delta_+0
integer(psb_ipk_), parameter :: mld_diag_scale_ = mld_slv_delta_+1
integer(psb_ipk_), parameter :: mld_gs_ = mld_slv_delta_+2
integer(psb_ipk_), parameter :: mld_ilu_n_ = mld_slv_delta_+3
integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+4
integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+5
integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+6
integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+7
integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+8
integer(psb_ipk_), parameter :: mld_mumps_ = mld_slv_delta_+9
integer(psb_ipk_), parameter :: mld_bwgs_ = mld_slv_delta_+10
integer(psb_ipk_), parameter :: mld_max_sub_solve_ = mld_slv_delta_+10
integer(psb_ipk_), parameter :: mld_min_sub_solve_ = mld_diag_scale_
!
! Legal values for entry: mld_sub_ren_
!
integer(psb_ipk_), parameter :: mld_renum_none_=0
integer(psb_ipk_), parameter :: mld_renum_glb_=1
integer(psb_ipk_), parameter :: mld_renum_gps_=2
integer(psb_ipk_), parameter :: mld_renum_none_ = 0
integer(psb_ipk_), parameter :: mld_renum_glb_ = 1
integer(psb_ipk_), parameter :: mld_renum_gps_ = 2
! For the time being we are disabling GPS renumbering.
integer(psb_ipk_), parameter :: mld_max_renum_=1
integer(psb_ipk_), parameter :: mld_max_renum_ = 1
!
! Legal values for entry: mld_ilu_scale_
!
@ -217,40 +218,40 @@ module mld_base_prec_type
!
integer(psb_ipk_), parameter :: mld_no_ml_ = 0
integer(psb_ipk_), parameter :: mld_add_ml_ = 1
integer(psb_ipk_), parameter :: mld_mult_ml_ = 2
integer(psb_ipk_), parameter :: mld_mult_ml_ = 2
integer(psb_ipk_), parameter :: mld_new_ml_prec_ = 3
integer(psb_ipk_), parameter :: mld_max_ml_type_ = mld_mult_ml_
!
! Legal values for entry: mld_smoother_pos_
!
integer(psb_ipk_), parameter :: mld_pre_smooth_=1
integer(psb_ipk_), parameter :: mld_post_smooth_=2
integer(psb_ipk_), parameter :: mld_twoside_smooth_=3
integer(psb_ipk_), parameter :: mld_max_smooth_=mld_twoside_smooth_
integer(psb_ipk_), parameter :: mld_pre_smooth_ = 1
integer(psb_ipk_), parameter :: mld_post_smooth_ = 2
integer(psb_ipk_), parameter :: mld_twoside_smooth_ = 3
integer(psb_ipk_), parameter :: mld_max_smooth_ = mld_twoside_smooth_
!
! Legal values for entry: mld_aggr_kind_
!
integer(psb_ipk_), parameter :: mld_no_smooth_ = 0
integer(psb_ipk_), parameter :: mld_no_smooth_ = 0
integer(psb_ipk_), parameter :: mld_smooth_prol_ = 1
integer(psb_ipk_), parameter :: mld_min_energy_ = 2
integer(psb_ipk_), parameter :: mld_min_energy_ = 2
integer(psb_ipk_), parameter :: mld_biz_prol_ = 3
! Disabling biz_prol for the time being.
integer(psb_ipk_), parameter :: mld_max_aggr_kind_=mld_min_energy_
!
! Legal values for entry: mld_aggr_filter_
!
integer(psb_ipk_), parameter :: mld_no_filter_mat_=0
integer(psb_ipk_), parameter :: mld_filter_mat_=1
integer(psb_ipk_), parameter :: mld_max_filter_mat_=mld_no_filter_mat_
integer(psb_ipk_), parameter :: mld_no_filter_mat_ = 0
integer(psb_ipk_), parameter :: mld_filter_mat_ = 1
integer(psb_ipk_), parameter :: mld_max_filter_mat_ = mld_no_filter_mat_
!
! Legal values for entry: mld_aggr_alg_
!
integer(psb_ipk_), parameter :: mld_dec_aggr_=0
integer(psb_ipk_), parameter :: mld_sym_dec_aggr_=1
integer(psb_ipk_), parameter :: mld_glb_aggr_=2
integer(psb_ipk_), parameter :: mld_new_dec_aggr_=3
integer(psb_ipk_), parameter :: mld_new_glb_aggr_=4
integer(psb_ipk_), parameter :: mld_max_aggr_alg_=mld_sym_dec_aggr_
integer(psb_ipk_), parameter :: mld_dec_aggr_ = 0
integer(psb_ipk_), parameter :: mld_sym_dec_aggr_ = 1
integer(psb_ipk_), parameter :: mld_glb_aggr_ = 2
integer(psb_ipk_), parameter :: mld_new_dec_aggr_ = 3
integer(psb_ipk_), parameter :: mld_new_glb_aggr_ = 4
integer(psb_ipk_), parameter :: mld_max_aggr_alg_ = mld_sym_dec_aggr_
!
! Legal values for entry: mld_aggr_ord_
!
@ -260,22 +261,22 @@ module mld_base_prec_type
!
! Legal values for entry: mld_aggr_omega_alg_
!
integer(psb_ipk_), parameter :: mld_eig_est_=0
integer(psb_ipk_), parameter :: mld_user_choice_=999
integer(psb_ipk_), parameter :: mld_eig_est_ = 0
integer(psb_ipk_), parameter :: mld_user_choice_ = 999
!
! Legal values for entry: mld_aggr_eig_
!
integer(psb_ipk_), parameter :: mld_max_norm_=0
integer(psb_ipk_), parameter :: mld_max_norm_ = 0
!
! Legal values for entry: mld_coarse_mat_
!
integer(psb_ipk_), parameter :: mld_distr_mat_=0
integer(psb_ipk_), parameter :: mld_repl_mat_=1
integer(psb_ipk_), parameter :: mld_max_coarse_mat_=mld_repl_mat_
integer(psb_ipk_), parameter :: mld_distr_mat_ = 0
integer(psb_ipk_), parameter :: mld_repl_mat_ = 1
integer(psb_ipk_), parameter :: mld_max_coarse_mat_ = mld_repl_mat_
!
! Legal values for entry: mld_prec_status_
!
integer(psb_ipk_), parameter :: mld_prec_built_=98765
integer(psb_ipk_), parameter :: mld_prec_built_ = 98765
!
! Entries in rprcparm: ILU(k,t) threshold, smoothed aggregation omega
@ -293,7 +294,7 @@ module mld_base_prec_type
! Entries for mumps
!
!parameter controling the sequential/parallel building of MUMPS
integer(psb_ipk_), parameter :: mld_as_sequential_ =40
integer(psb_ipk_), parameter :: mld_as_sequential_ = 40
!parameter regulating the error printing of MUMPS
integer(psb_ipk_), parameter :: mld_mumps_print_err_ = 41
@ -343,7 +344,8 @@ module mld_base_prec_type
& 'Gauss-Seidel ','ILU(n) ',&
& 'MILU(n) ','ILU(t,n) ',&
& 'SuperLU ','UMFPACK LU ',&
& 'SuperLU_Dist ','MUMPS '/)
& 'SuperLU_Dist ','MUMPS ',&
& 'Backward GS '/)
interface mld_check_def
module procedure mld_icheck_def, mld_scheck_def, mld_dcheck_def
@ -393,8 +395,10 @@ contains
val = psb_avg_
case('FACT_NONE')
val = mld_f_none_
case('GS')
case('GS','FWGS')
val = mld_gs_
case('BWGS')
val = mld_bwgs_
case('ILU')
val = mld_ilu_n_
case('MILU')

118
mlprec/mld_c_gs_solver.f90
Unescape Escape View File

@ -74,15 +74,25 @@ module mld_c_gs_solver
procedure, nopass :: is_iterative => d_gs_solver_is_iterative
end type mld_c_gs_solver_type
type, extends(mld_c_gs_solver_type) :: mld_c_bwgs_solver_type
contains
procedure, pass(sv) :: build => mld_c_bwgs_solver_bld
procedure, pass(sv) :: apply_v => mld_c_bwgs_solver_apply_vect
procedure, pass(sv) :: apply_a => mld_c_bwgs_solver_apply
procedure, nopass :: get_fmt => c_bwgs_solver_get_fmt
procedure, pass(sv) :: descr => c_bwgs_solver_descr
end type mld_c_bwgs_solver_type
private :: d_gs_solver_bld, d_gs_solver_apply, &
& d_gs_solver_free, d_gs_solver_seti, &
& d_gs_solver_setc, d_gs_solver_setr,&
& d_gs_solver_descr, d_gs_solver_sizeof, &
& d_gs_solver_default, d_gs_solver_dmp, &
& d_gs_solver_apply_vect, d_gs_solver_get_nzeros, &
& d_gs_solver_get_fmt, d_gs_solver_check,&
& d_gs_solver_is_iterative
private :: c_gs_solver_bld, c_gs_solver_apply, &
& c_gs_solver_free, c_gs_solver_seti, &
& c_gs_solver_setc, c_gs_solver_setr,&
& c_gs_solver_descr, c_gs_solver_sizeof, &
& c_gs_solver_default, c_gs_solver_dmp, &
& c_gs_solver_apply_vect, c_gs_solver_get_nzeros, &
& c_gs_solver_get_fmt, c_gs_solver_check,&
& c_gs_solver_is_iterative, &
& c_bwgs_solver_get_fmt, c_bwgs_solver_descr
interface
@ -99,6 +109,19 @@ module mld_c_gs_solver
complex(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_c_gs_solver_apply_vect
subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_c_bwgs_solver_type), intent(inout) :: sv
type(psb_c_vect_type),intent(inout) :: x
type(psb_c_vect_type),intent(inout) :: y
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_c_bwgs_solver_apply_vect
end interface
interface
@ -115,6 +138,19 @@ module mld_c_gs_solver
complex(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_c_gs_solver_apply
subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_c_bwgs_solver_type), intent(inout) :: sv
complex(psb_spk_),intent(inout) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_c_bwgs_solver_apply
end interface
interface
@ -133,6 +169,21 @@ module mld_c_gs_solver
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine mld_c_gs_solver_bld
subroutine mld_c_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold)
import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_c_bwgs_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
type(psb_cspmat_type), intent(in), target, optional :: b
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine mld_c_bwgs_solver_bld
end interface
interface
@ -452,10 +503,10 @@ contains
endif
if (sv%eps<=dzero) then
write(iout_,*) ' Gauss-Seidel iterative solver with ',&
write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',&
write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
@ -500,7 +551,7 @@ contains
implicit none
character(len=32) :: val
val = "Gauss-Seidel solver"
val = "Forward Gauss-Seidel solver"
end function d_gs_solver_get_fmt
@ -514,5 +565,50 @@ contains
val = .true.
end function d_gs_solver_is_iterative
subroutine c_bwgs_solver_descr(sv,info,iout,coarse)
Implicit None
! Arguments
class(mld_c_bwgs_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='mld_c_bwgs_solver_descr'
integer(psb_ipk_) :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
if (sv%eps<=dzero) then
write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine c_bwgs_solver_descr
function c_bwgs_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Backward Gauss-Seidel solver"
end function c_bwgs_solver_get_fmt
end module mld_c_gs_solver

96
mlprec/mld_c_onelev_mod.f90
Unescape Escape View File

@ -121,7 +121,8 @@ module mld_c_onelev_mod
!
!
type mld_c_onelev_type
class(mld_c_base_smoother_type), allocatable :: sm
class(mld_c_base_smoother_type), allocatable :: sm, sm2a
class(mld_c_base_smoother_type), pointer :: sm2 => null()
type(mld_sml_parms) :: parms
type(psb_cspmat_type) :: ac
integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot
@ -144,7 +145,10 @@ module mld_c_onelev_mod
procedure, pass(lv) :: cseti => mld_c_base_onelev_cseti
procedure, pass(lv) :: csetr => mld_c_base_onelev_csetr
procedure, pass(lv) :: csetc => mld_c_base_onelev_csetc
generic, public :: set => seti, setr, setc, cseti, csetr, csetc
procedure, pass(lv) :: setsm => mld_c_base_onelev_setsm
procedure, pass(lv) :: setsv => mld_c_base_onelev_setsv
generic, public :: set => seti, setr, setc, &
& cseti, csetr, csetc, setsm, setsv
procedure, pass(lv) :: sizeof => c_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros
procedure, nopass :: stringval => mld_stringval
@ -213,7 +217,7 @@ module mld_c_onelev_mod
end interface
interface
subroutine mld_c_base_onelev_seti(lv,what,val,info)
subroutine mld_c_base_onelev_seti(lv,what,val,info,pos)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, mld_c_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -224,11 +228,40 @@ module mld_c_onelev_mod
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_c_base_onelev_seti
end interface
interface
subroutine mld_c_base_onelev_setsm(lv,val,info,pos)
import :: psb_spk_, mld_c_onelev_type, mld_c_base_smoother_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
Implicit None
! Arguments
class(mld_c_onelev_type), target, intent(inout) :: lv
class(mld_c_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_c_base_onelev_setsm
end interface
interface
subroutine mld_c_base_onelev_setc(lv,what,val,info)
subroutine mld_c_base_onelev_setsv(lv,val,info,pos)
import :: psb_spk_, mld_c_onelev_type, mld_c_base_solver_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
Implicit None
! Arguments
class(mld_c_onelev_type), target, intent(inout) :: lv
class(mld_c_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_c_base_onelev_setsv
end interface
interface
subroutine mld_c_base_onelev_setc(lv,what,val,info,pos)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, mld_c_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -238,11 +271,12 @@ module mld_c_onelev_mod
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_c_base_onelev_setc
end interface
interface
subroutine mld_c_base_onelev_setr(lv,what,val,info)
subroutine mld_c_base_onelev_setr(lv,what,val,info,pos)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, mld_c_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -252,12 +286,13 @@ module mld_c_onelev_mod
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_c_base_onelev_setr
end interface
interface
subroutine mld_c_base_onelev_cseti(lv,what,val,info)
subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, mld_c_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -268,11 +303,12 @@ module mld_c_onelev_mod
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_c_base_onelev_cseti
end interface
interface
subroutine mld_c_base_onelev_csetc(lv,what,val,info)
subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, mld_c_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -282,11 +318,12 @@ module mld_c_onelev_mod
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_c_base_onelev_csetc
end interface
interface
subroutine mld_c_base_onelev_csetr(lv,what,val,info)
subroutine mld_c_base_onelev_csetr(lv,what,val,info,pos)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, mld_c_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -296,6 +333,7 @@ module mld_c_onelev_mod
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_c_base_onelev_csetr
end interface
@ -331,6 +369,8 @@ contains
val = 0
if (allocated(lv%sm)) &
& val = lv%sm%get_nzeros()
if (allocated(lv%sm2a)) &
& val = val + lv%sm2a%get_nzeros()
end function c_base_onelev_get_nzeros
function c_base_onelev_sizeof(lv) result(val)
@ -344,6 +384,7 @@ contains
val = val + lv%ac%sizeof()
val = val + lv%map%sizeof()
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
end function c_base_onelev_sizeof
@ -354,7 +395,7 @@ contains
nullify(lv%base_a)
nullify(lv%base_desc)
nullify(lv%sm2)
end subroutine c_base_onelev_nullify
!
@ -370,9 +411,9 @@ contains
subroutine c_base_onelev_default(lv)
Implicit None
! Arguments
class(mld_c_onelev_type), intent(inout) :: lv
class(mld_c_onelev_type), target, intent(inout) :: lv
lv%parms%sweeps = 1
lv%parms%sweeps_pre = 1
@ -390,6 +431,12 @@ contains
lv%parms%aggr_thresh = szero
if (allocated(lv%sm)) call lv%sm%default()
if (allocated(lv%sm2a)) then
call lv%sm2a%default()
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
return
@ -403,8 +450,8 @@ contains
! Arguments
class(mld_c_onelev_type), target, intent(inout) :: lv
class(mld_c_onelev_type), intent(inout) :: lvout
integer(psb_ipk_), intent(out) :: info
class(mld_c_onelev_type), target, intent(inout) :: lvout
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (allocated(lv%sm)) then
@ -415,6 +462,16 @@ contains
if (info==psb_success_) deallocate(lvout%sm,stat=info)
end if
end if
if (allocated(lv%sm2a)) then
call lv%sm%clone(lvout%sm2a,info)
lvout%sm2 => lvout%sm2a
else
if (allocated(lvout%sm2a)) then
call lvout%sm2a%free(info)
if (info==psb_success_) deallocate(lvout%sm2a,stat=info)
end if
lvout%sm2 => lvout%sm
end if
if (info == psb_success_) call lv%parms%clone(lvout%parms,info)
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
@ -430,12 +487,21 @@ contains
subroutine mld_c_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_c_onelev_type), intent(inout) :: a, b
type(mld_c_onelev_type), target, intent(inout) :: a, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (associated(a%sm2,a%sm2a)) then
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%sm2 =>b%sm2a
else
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%sm2 =>b%sm
end if
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)

41
mlprec/mld_c_prec_mod.f90
Unescape Escape View File

@ -91,74 +91,81 @@ module mld_c_prec_mod
contains
subroutine mld_c_iprecsetsm(p,val,info)
subroutine mld_c_iprecsetsm(p,val,info,pos)
type(mld_cprec_type), intent(inout) :: p
class(mld_c_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(val,info)
call p%set(val,info,pos=pos)
end subroutine mld_c_iprecsetsm
subroutine mld_c_iprecsetsv(p,val,info)
subroutine mld_c_iprecsetsv(p,val,info,pos)
type(mld_cprec_type), intent(inout) :: p
class(mld_c_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
call p%set(val,info)
character(len=*), optional, intent(in) :: pos
call p%set(val,info, pos=pos)
end subroutine mld_c_iprecsetsv
subroutine mld_c_iprecseti(p,what,val,info)
subroutine mld_c_iprecseti(p,what,val,info,pos)
type(mld_cprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_c_iprecseti
subroutine mld_c_iprecsetr(p,what,val,info)
subroutine mld_c_iprecsetr(p,what,val,info,pos)
type(mld_cprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_c_iprecsetr
subroutine mld_c_iprecsetc(p,what,val,info)
subroutine mld_c_iprecsetc(p,what,val,info,pos)
type(mld_cprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_c_iprecsetc
subroutine mld_c_cprecseti(p,what,val,info)
subroutine mld_c_cprecseti(p,what,val,info,pos)
type(mld_cprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_c_cprecseti
subroutine mld_c_cprecsetr(p,what,val,info)
subroutine mld_c_cprecsetr(p,what,val,info,pos)
type(mld_cprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_c_cprecsetr
subroutine mld_c_cprecsetc(p,what,val,info)
subroutine mld_c_cprecsetc(p,what,val,info,pos)
type(mld_cprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_c_cprecsetc
end module mld_c_prec_mod

42
mlprec/mld_c_prec_type.f90
Unescape Escape View File

@ -175,23 +175,25 @@ module mld_c_prec_type
end interface
interface
subroutine mld_cprecsetsm(prec,val,info,ilev)
subroutine mld_cprecsetsm(prec,val,info,ilev,pos)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& mld_cprec_type, mld_c_base_smoother_type, psb_ipk_
class(mld_cprec_type), intent(inout) :: prec
class(mld_cprec_type), target, intent(inout):: prec
class(mld_c_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_cprecsetsm
subroutine mld_cprecsetsv(prec,val,info,ilev)
subroutine mld_cprecsetsv(prec,val,info,ilev,pos)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& mld_cprec_type, mld_c_base_solver_type, psb_ipk_
class(mld_cprec_type), intent(inout) :: prec
class(mld_c_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_cprecsetsv
subroutine mld_cprecseti(prec,what,val,info,ilev)
subroutine mld_cprecseti(prec,what,val,info,ilev,pos)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& mld_cprec_type, psb_ipk_
class(mld_cprec_type), intent(inout) :: prec
@ -199,8 +201,9 @@ module mld_c_prec_type
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_cprecseti
subroutine mld_cprecsetr(prec,what,val,info,ilev)
subroutine mld_cprecsetr(prec,what,val,info,ilev,pos)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& mld_cprec_type, psb_ipk_
class(mld_cprec_type), intent(inout) :: prec
@ -208,8 +211,9 @@ module mld_c_prec_type
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_cprecsetr
subroutine mld_cprecsetc(prec,what,string,info,ilev)
subroutine mld_cprecsetc(prec,what,string,info,ilev,pos)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& mld_cprec_type, psb_ipk_
class(mld_cprec_type), intent(inout) :: prec
@ -217,8 +221,9 @@ module mld_c_prec_type
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_cprecsetc
subroutine mld_ccprecseti(prec,what,val,info,ilev)
subroutine mld_ccprecseti(prec,what,val,info,ilev,pos)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& mld_cprec_type, psb_ipk_
class(mld_cprec_type), intent(inout) :: prec
@ -226,8 +231,9 @@ module mld_c_prec_type
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_ccprecseti
subroutine mld_ccprecsetr(prec,what,val,info,ilev)
subroutine mld_ccprecsetr(prec,what,val,info,ilev,pos)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& mld_cprec_type, psb_ipk_
class(mld_cprec_type), intent(inout) :: prec
@ -235,8 +241,9 @@ module mld_c_prec_type
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_ccprecsetr
subroutine mld_ccprecsetc(prec,what,string,info,ilev)
subroutine mld_ccprecsetc(prec,what,string,info,ilev,pos)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& mld_cprec_type, psb_ipk_
class(mld_cprec_type), intent(inout) :: prec
@ -244,6 +251,7 @@ module mld_c_prec_type
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_ccprecsetc
end interface
@ -477,6 +485,18 @@ contains
write(iout_,*)
return
end if
if (allocated(p%precv(1)%sm2a)) then
write(iout_,*) 'Post smoother details'
call p%precv(1)%sm2a%descr(info,iout=iout_)
if (nlev == 1) then
if (p%precv(1)%parms%sweeps > 1) then
write(iout_,*) ' Number of smoother sweeps : ',&
& p%precv(1)%parms%sweeps
end if
write(iout_,*)
return
end if
end if
end if
!

15
mlprec/mld_d_gs_solver.f90
Unescape Escape View File

@ -76,14 +76,13 @@ module mld_d_gs_solver
type, extends(mld_d_gs_solver_type) :: mld_d_bwgs_solver_type
contains
procedure, pass(sv) :: build => mld_d_bwgs_solver_bld
procedure, pass(sv) :: apply_v => mld_d_bwgs_solver_apply_vect
procedure, pass(sv) :: apply_a => mld_d_bwgs_solver_apply
procedure, nopass :: get_fmt => d_bwgs_solver_get_fmt
procedure, pass(sv) :: descr => d_bwgs_solver_descr
procedure, pass(sv) :: build => mld_d_bwgs_solver_bld
procedure, pass(sv) :: apply_v => mld_d_bwgs_solver_apply_vect
procedure, pass(sv) :: apply_a => mld_d_bwgs_solver_apply
procedure, nopass :: get_fmt => d_bwgs_solver_get_fmt
procedure, pass(sv) :: descr => d_bwgs_solver_descr
end type mld_d_bwgs_solver_type
private :: d_gs_solver_bld, d_gs_solver_apply, &
& d_gs_solver_free, d_gs_solver_seti, &
@ -566,8 +565,7 @@ contains
val = .true.
end function d_gs_solver_is_iterative
subroutine d_bwgs_solver_descr(sv,info,iout,coarse)
Implicit None
@ -613,5 +611,4 @@ contains
val = "Backward Gauss-Seidel solver"
end function d_bwgs_solver_get_fmt
end module mld_d_gs_solver

10
mlprec/mld_d_onelev_mod.f90
Unescape Escape View File

@ -122,7 +122,7 @@ module mld_d_onelev_mod
!
type mld_d_onelev_type
class(mld_d_base_smoother_type), allocatable :: sm, sm2a
class(mld_d_base_smoother_type), pointer :: sm2
class(mld_d_base_smoother_type), pointer :: sm2 => null()
type(mld_dml_parms) :: parms
type(psb_dspmat_type) :: ac
integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot
@ -147,7 +147,7 @@ module mld_d_onelev_mod
procedure, pass(lv) :: csetc => mld_d_base_onelev_csetc
procedure, pass(lv) :: setsm => mld_d_base_onelev_setsm
procedure, pass(lv) :: setsv => mld_d_base_onelev_setsv
generic, public :: set => seti, setr, setc,&
generic, public :: set => seti, setr, setc, &
& cseti, csetr, csetc, setsm, setsv
procedure, pass(lv) :: sizeof => d_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros
@ -231,7 +231,7 @@ module mld_d_onelev_mod
character(len=*), optional, intent(in) :: pos
end subroutine mld_d_base_onelev_seti
end interface
interface
subroutine mld_d_base_onelev_setsm(lv,val,info,pos)
import :: psb_dpk_, mld_d_onelev_type, mld_d_base_smoother_type, &
@ -411,7 +411,7 @@ contains
subroutine d_base_onelev_default(lv)
Implicit None
! Arguments
class(mld_d_onelev_type), target, intent(inout) :: lv
@ -451,7 +451,7 @@ contains
! Arguments
class(mld_d_onelev_type), target, intent(inout) :: lv
class(mld_d_onelev_type), target, intent(inout) :: lvout
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (allocated(lv%sm)) then

6
mlprec/mld_d_prec_type.f90
Unescape Escape View File

@ -178,10 +178,10 @@ module mld_d_prec_type
subroutine mld_dprecsetsm(prec,val,info,ilev,pos)
import :: psb_dspmat_type, psb_desc_type, psb_dpk_, &
& mld_dprec_type, mld_d_base_smoother_type, psb_ipk_
class(mld_dprec_type), target, intent(inout) :: prec
class(mld_dprec_type), target, intent(inout):: prec
class(mld_d_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_dprecsetsm
subroutine mld_dprecsetsv(prec,val,info,ilev,pos)

118
mlprec/mld_s_gs_solver.f90
Unescape Escape View File

@ -74,15 +74,25 @@ module mld_s_gs_solver
procedure, nopass :: is_iterative => d_gs_solver_is_iterative
end type mld_s_gs_solver_type
type, extends(mld_s_gs_solver_type) :: mld_s_bwgs_solver_type
contains
procedure, pass(sv) :: build => mld_s_bwgs_solver_bld
procedure, pass(sv) :: apply_v => mld_s_bwgs_solver_apply_vect
procedure, pass(sv) :: apply_a => mld_s_bwgs_solver_apply
procedure, nopass :: get_fmt => s_bwgs_solver_get_fmt
procedure, pass(sv) :: descr => s_bwgs_solver_descr
end type mld_s_bwgs_solver_type
private :: d_gs_solver_bld, d_gs_solver_apply, &
& d_gs_solver_free, d_gs_solver_seti, &
& d_gs_solver_setc, d_gs_solver_setr,&
& d_gs_solver_descr, d_gs_solver_sizeof, &
& d_gs_solver_default, d_gs_solver_dmp, &
& d_gs_solver_apply_vect, d_gs_solver_get_nzeros, &
& d_gs_solver_get_fmt, d_gs_solver_check,&
& d_gs_solver_is_iterative
private :: s_gs_solver_bld, s_gs_solver_apply, &
& s_gs_solver_free, s_gs_solver_seti, &
& s_gs_solver_setc, s_gs_solver_setr,&
& s_gs_solver_descr, s_gs_solver_sizeof, &
& s_gs_solver_default, s_gs_solver_dmp, &
& s_gs_solver_apply_vect, s_gs_solver_get_nzeros, &
& s_gs_solver_get_fmt, s_gs_solver_check,&
& s_gs_solver_is_iterative, &
& s_bwgs_solver_get_fmt, s_bwgs_solver_descr
interface
@ -99,6 +109,19 @@ module mld_s_gs_solver
real(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_s_gs_solver_apply_vect
subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_bwgs_solver_type), intent(inout) :: sv
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_s_bwgs_solver_apply_vect
end interface
interface
@ -115,6 +138,19 @@ module mld_s_gs_solver
real(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_s_gs_solver_apply
subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_bwgs_solver_type), intent(inout) :: sv
real(psb_spk_),intent(inout) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_s_bwgs_solver_apply
end interface
interface
@ -133,6 +169,21 @@ module mld_s_gs_solver
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine mld_s_gs_solver_bld
subroutine mld_s_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold)
import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_bwgs_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine mld_s_bwgs_solver_bld
end interface
interface
@ -452,10 +503,10 @@ contains
endif
if (sv%eps<=dzero) then
write(iout_,*) ' Gauss-Seidel iterative solver with ',&
write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',&
write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
@ -500,7 +551,7 @@ contains
implicit none
character(len=32) :: val
val = "Gauss-Seidel solver"
val = "Forward Gauss-Seidel solver"
end function d_gs_solver_get_fmt
@ -514,5 +565,50 @@ contains
val = .true.
end function d_gs_solver_is_iterative
subroutine s_bwgs_solver_descr(sv,info,iout,coarse)
Implicit None
! Arguments
class(mld_s_bwgs_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='mld_s_bwgs_solver_descr'
integer(psb_ipk_) :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
if (sv%eps<=dzero) then
write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_bwgs_solver_descr
function s_bwgs_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Backward Gauss-Seidel solver"
end function s_bwgs_solver_get_fmt
end module mld_s_gs_solver

96
mlprec/mld_s_onelev_mod.f90
Unescape Escape View File

@ -121,7 +121,8 @@ module mld_s_onelev_mod
!
!
type mld_s_onelev_type
class(mld_s_base_smoother_type), allocatable :: sm
class(mld_s_base_smoother_type), allocatable :: sm, sm2a
class(mld_s_base_smoother_type), pointer :: sm2 => null()
type(mld_sml_parms) :: parms
type(psb_sspmat_type) :: ac
integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot
@ -144,7 +145,10 @@ module mld_s_onelev_mod
procedure, pass(lv) :: cseti => mld_s_base_onelev_cseti
procedure, pass(lv) :: csetr => mld_s_base_onelev_csetr
procedure, pass(lv) :: csetc => mld_s_base_onelev_csetc
generic, public :: set => seti, setr, setc, cseti, csetr, csetc
procedure, pass(lv) :: setsm => mld_s_base_onelev_setsm
procedure, pass(lv) :: setsv => mld_s_base_onelev_setsv
generic, public :: set => seti, setr, setc, &
& cseti, csetr, csetc, setsm, setsv
procedure, pass(lv) :: sizeof => s_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros
procedure, nopass :: stringval => mld_stringval
@ -213,7 +217,7 @@ module mld_s_onelev_mod
end interface
interface
subroutine mld_s_base_onelev_seti(lv,what,val,info)
subroutine mld_s_base_onelev_seti(lv,what,val,info,pos)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, mld_s_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -224,11 +228,40 @@ module mld_s_onelev_mod
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_s_base_onelev_seti
end interface
interface
subroutine mld_s_base_onelev_setsm(lv,val,info,pos)
import :: psb_spk_, mld_s_onelev_type, mld_s_base_smoother_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
Implicit None
! Arguments
class(mld_s_onelev_type), target, intent(inout) :: lv
class(mld_s_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_s_base_onelev_setsm
end interface
interface
subroutine mld_s_base_onelev_setc(lv,what,val,info)
subroutine mld_s_base_onelev_setsv(lv,val,info,pos)
import :: psb_spk_, mld_s_onelev_type, mld_s_base_solver_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
Implicit None
! Arguments
class(mld_s_onelev_type), target, intent(inout) :: lv
class(mld_s_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_s_base_onelev_setsv
end interface
interface
subroutine mld_s_base_onelev_setc(lv,what,val,info,pos)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, mld_s_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -238,11 +271,12 @@ module mld_s_onelev_mod
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_s_base_onelev_setc
end interface
interface
subroutine mld_s_base_onelev_setr(lv,what,val,info)
subroutine mld_s_base_onelev_setr(lv,what,val,info,pos)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, mld_s_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -252,12 +286,13 @@ module mld_s_onelev_mod
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_s_base_onelev_setr
end interface
interface
subroutine mld_s_base_onelev_cseti(lv,what,val,info)
subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, mld_s_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -268,11 +303,12 @@ module mld_s_onelev_mod
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_s_base_onelev_cseti
end interface
interface
subroutine mld_s_base_onelev_csetc(lv,what,val,info)
subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, mld_s_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -282,11 +318,12 @@ module mld_s_onelev_mod
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_s_base_onelev_csetc
end interface
interface
subroutine mld_s_base_onelev_csetr(lv,what,val,info)
subroutine mld_s_base_onelev_csetr(lv,what,val,info,pos)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, mld_s_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -296,6 +333,7 @@ module mld_s_onelev_mod
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_s_base_onelev_csetr
end interface
@ -331,6 +369,8 @@ contains
val = 0
if (allocated(lv%sm)) &
& val = lv%sm%get_nzeros()
if (allocated(lv%sm2a)) &
& val = val + lv%sm2a%get_nzeros()
end function s_base_onelev_get_nzeros
function s_base_onelev_sizeof(lv) result(val)
@ -344,6 +384,7 @@ contains
val = val + lv%ac%sizeof()
val = val + lv%map%sizeof()
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
end function s_base_onelev_sizeof
@ -354,7 +395,7 @@ contains
nullify(lv%base_a)
nullify(lv%base_desc)
nullify(lv%sm2)
end subroutine s_base_onelev_nullify
!
@ -370,9 +411,9 @@ contains
subroutine s_base_onelev_default(lv)
Implicit None
! Arguments
class(mld_s_onelev_type), intent(inout) :: lv
class(mld_s_onelev_type), target, intent(inout) :: lv
lv%parms%sweeps = 1
lv%parms%sweeps_pre = 1
@ -390,6 +431,12 @@ contains
lv%parms%aggr_thresh = szero
if (allocated(lv%sm)) call lv%sm%default()
if (allocated(lv%sm2a)) then
call lv%sm2a%default()
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
return
@ -403,8 +450,8 @@ contains
! Arguments
class(mld_s_onelev_type), target, intent(inout) :: lv
class(mld_s_onelev_type), intent(inout) :: lvout
integer(psb_ipk_), intent(out) :: info
class(mld_s_onelev_type), target, intent(inout) :: lvout
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (allocated(lv%sm)) then
@ -415,6 +462,16 @@ contains
if (info==psb_success_) deallocate(lvout%sm,stat=info)
end if
end if
if (allocated(lv%sm2a)) then
call lv%sm%clone(lvout%sm2a,info)
lvout%sm2 => lvout%sm2a
else
if (allocated(lvout%sm2a)) then
call lvout%sm2a%free(info)
if (info==psb_success_) deallocate(lvout%sm2a,stat=info)
end if
lvout%sm2 => lvout%sm
end if
if (info == psb_success_) call lv%parms%clone(lvout%parms,info)
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
@ -430,12 +487,21 @@ contains
subroutine mld_s_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_s_onelev_type), intent(inout) :: a, b
type(mld_s_onelev_type), target, intent(inout) :: a, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (associated(a%sm2,a%sm2a)) then
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%sm2 =>b%sm2a
else
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%sm2 =>b%sm
end if
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)

41
mlprec/mld_s_prec_mod.f90
Unescape Escape View File

@ -91,74 +91,81 @@ module mld_s_prec_mod
contains
subroutine mld_s_iprecsetsm(p,val,info)
subroutine mld_s_iprecsetsm(p,val,info,pos)
type(mld_sprec_type), intent(inout) :: p
class(mld_s_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(val,info)
call p%set(val,info,pos=pos)
end subroutine mld_s_iprecsetsm
subroutine mld_s_iprecsetsv(p,val,info)
subroutine mld_s_iprecsetsv(p,val,info,pos)
type(mld_sprec_type), intent(inout) :: p
class(mld_s_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
call p%set(val,info)
character(len=*), optional, intent(in) :: pos
call p%set(val,info, pos=pos)
end subroutine mld_s_iprecsetsv
subroutine mld_s_iprecseti(p,what,val,info)
subroutine mld_s_iprecseti(p,what,val,info,pos)
type(mld_sprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_s_iprecseti
subroutine mld_s_iprecsetr(p,what,val,info)
subroutine mld_s_iprecsetr(p,what,val,info,pos)
type(mld_sprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_s_iprecsetr
subroutine mld_s_iprecsetc(p,what,val,info)
subroutine mld_s_iprecsetc(p,what,val,info,pos)
type(mld_sprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_s_iprecsetc
subroutine mld_s_cprecseti(p,what,val,info)
subroutine mld_s_cprecseti(p,what,val,info,pos)
type(mld_sprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_s_cprecseti
subroutine mld_s_cprecsetr(p,what,val,info)
subroutine mld_s_cprecsetr(p,what,val,info,pos)
type(mld_sprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_s_cprecsetr
subroutine mld_s_cprecsetc(p,what,val,info)
subroutine mld_s_cprecsetc(p,what,val,info,pos)
type(mld_sprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_s_cprecsetc
end module mld_s_prec_mod

42
mlprec/mld_s_prec_type.f90
Unescape Escape View File

@ -175,23 +175,25 @@ module mld_s_prec_type
end interface
interface
subroutine mld_sprecsetsm(prec,val,info,ilev)
subroutine mld_sprecsetsm(prec,val,info,ilev,pos)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& mld_sprec_type, mld_s_base_smoother_type, psb_ipk_
class(mld_sprec_type), intent(inout) :: prec
class(mld_sprec_type), target, intent(inout):: prec
class(mld_s_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_sprecsetsm
subroutine mld_sprecsetsv(prec,val,info,ilev)
subroutine mld_sprecsetsv(prec,val,info,ilev,pos)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& mld_sprec_type, mld_s_base_solver_type, psb_ipk_
class(mld_sprec_type), intent(inout) :: prec
class(mld_s_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_sprecsetsv
subroutine mld_sprecseti(prec,what,val,info,ilev)
subroutine mld_sprecseti(prec,what,val,info,ilev,pos)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& mld_sprec_type, psb_ipk_
class(mld_sprec_type), intent(inout) :: prec
@ -199,8 +201,9 @@ module mld_s_prec_type
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_sprecseti
subroutine mld_sprecsetr(prec,what,val,info,ilev)
subroutine mld_sprecsetr(prec,what,val,info,ilev,pos)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& mld_sprec_type, psb_ipk_
class(mld_sprec_type), intent(inout) :: prec
@ -208,8 +211,9 @@ module mld_s_prec_type
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_sprecsetr
subroutine mld_sprecsetc(prec,what,string,info,ilev)
subroutine mld_sprecsetc(prec,what,string,info,ilev,pos)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& mld_sprec_type, psb_ipk_
class(mld_sprec_type), intent(inout) :: prec
@ -217,8 +221,9 @@ module mld_s_prec_type
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_sprecsetc
subroutine mld_scprecseti(prec,what,val,info,ilev)
subroutine mld_scprecseti(prec,what,val,info,ilev,pos)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& mld_sprec_type, psb_ipk_
class(mld_sprec_type), intent(inout) :: prec
@ -226,8 +231,9 @@ module mld_s_prec_type
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_scprecseti
subroutine mld_scprecsetr(prec,what,val,info,ilev)
subroutine mld_scprecsetr(prec,what,val,info,ilev,pos)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& mld_sprec_type, psb_ipk_
class(mld_sprec_type), intent(inout) :: prec
@ -235,8 +241,9 @@ module mld_s_prec_type
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_scprecsetr
subroutine mld_scprecsetc(prec,what,string,info,ilev)
subroutine mld_scprecsetc(prec,what,string,info,ilev,pos)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& mld_sprec_type, psb_ipk_
class(mld_sprec_type), intent(inout) :: prec
@ -244,6 +251,7 @@ module mld_s_prec_type
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_scprecsetc
end interface
@ -477,6 +485,18 @@ contains
write(iout_,*)
return
end if
if (allocated(p%precv(1)%sm2a)) then
write(iout_,*) 'Post smoother details'
call p%precv(1)%sm2a%descr(info,iout=iout_)
if (nlev == 1) then
if (p%precv(1)%parms%sweeps > 1) then
write(iout_,*) ' Number of smoother sweeps : ',&
& p%precv(1)%parms%sweeps
end if
write(iout_,*)
return
end if
end if
end if
!

118
mlprec/mld_z_gs_solver.f90
Unescape Escape View File

@ -74,15 +74,25 @@ module mld_z_gs_solver
procedure, nopass :: is_iterative => d_gs_solver_is_iterative
end type mld_z_gs_solver_type
type, extends(mld_z_gs_solver_type) :: mld_z_bwgs_solver_type
contains
procedure, pass(sv) :: build => mld_z_bwgs_solver_bld
procedure, pass(sv) :: apply_v => mld_z_bwgs_solver_apply_vect
procedure, pass(sv) :: apply_a => mld_z_bwgs_solver_apply
procedure, nopass :: get_fmt => z_bwgs_solver_get_fmt
procedure, pass(sv) :: descr => z_bwgs_solver_descr
end type mld_z_bwgs_solver_type
private :: d_gs_solver_bld, d_gs_solver_apply, &
& d_gs_solver_free, d_gs_solver_seti, &
& d_gs_solver_setc, d_gs_solver_setr,&
& d_gs_solver_descr, d_gs_solver_sizeof, &
& d_gs_solver_default, d_gs_solver_dmp, &
& d_gs_solver_apply_vect, d_gs_solver_get_nzeros, &
& d_gs_solver_get_fmt, d_gs_solver_check,&
& d_gs_solver_is_iterative
private :: z_gs_solver_bld, z_gs_solver_apply, &
& z_gs_solver_free, z_gs_solver_seti, &
& z_gs_solver_setc, z_gs_solver_setr,&
& z_gs_solver_descr, z_gs_solver_sizeof, &
& z_gs_solver_default, z_gs_solver_dmp, &
& z_gs_solver_apply_vect, z_gs_solver_get_nzeros, &
& z_gs_solver_get_fmt, z_gs_solver_check,&
& z_gs_solver_is_iterative, &
& z_bwgs_solver_get_fmt, z_bwgs_solver_descr
interface
@ -99,6 +109,19 @@ module mld_z_gs_solver
complex(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_z_gs_solver_apply_vect
subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_z_bwgs_solver_type), intent(inout) :: sv
type(psb_z_vect_type),intent(inout) :: x
type(psb_z_vect_type),intent(inout) :: y
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_z_bwgs_solver_apply_vect
end interface
interface
@ -115,6 +138,19 @@ module mld_z_gs_solver
complex(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_z_gs_solver_apply
subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_z_bwgs_solver_type), intent(inout) :: sv
complex(psb_dpk_),intent(inout) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine mld_z_bwgs_solver_apply
end interface
interface
@ -133,6 +169,21 @@ module mld_z_gs_solver
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine mld_z_gs_solver_bld
subroutine mld_z_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold)
import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_zspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_z_bwgs_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
type(psb_zspmat_type), intent(in), target, optional :: b
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine mld_z_bwgs_solver_bld
end interface
interface
@ -452,10 +503,10 @@ contains
endif
if (sv%eps<=dzero) then
write(iout_,*) ' Gauss-Seidel iterative solver with ',&
write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',&
write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
@ -500,7 +551,7 @@ contains
implicit none
character(len=32) :: val
val = "Gauss-Seidel solver"
val = "Forward Gauss-Seidel solver"
end function d_gs_solver_get_fmt
@ -514,5 +565,50 @@ contains
val = .true.
end function d_gs_solver_is_iterative
subroutine z_bwgs_solver_descr(sv,info,iout,coarse)
Implicit None
! Arguments
class(mld_z_bwgs_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='mld_z_bwgs_solver_descr'
integer(psb_ipk_) :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
if (sv%eps<=dzero) then
write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine z_bwgs_solver_descr
function z_bwgs_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Backward Gauss-Seidel solver"
end function z_bwgs_solver_get_fmt
end module mld_z_gs_solver

96
mlprec/mld_z_onelev_mod.f90
Unescape Escape View File

@ -121,7 +121,8 @@ module mld_z_onelev_mod
!
!
type mld_z_onelev_type
class(mld_z_base_smoother_type), allocatable :: sm
class(mld_z_base_smoother_type), allocatable :: sm, sm2a
class(mld_z_base_smoother_type), pointer :: sm2 => null()
type(mld_dml_parms) :: parms
type(psb_zspmat_type) :: ac
integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot
@ -144,7 +145,10 @@ module mld_z_onelev_mod
procedure, pass(lv) :: cseti => mld_z_base_onelev_cseti
procedure, pass(lv) :: csetr => mld_z_base_onelev_csetr
procedure, pass(lv) :: csetc => mld_z_base_onelev_csetc
generic, public :: set => seti, setr, setc, cseti, csetr, csetc
procedure, pass(lv) :: setsm => mld_z_base_onelev_setsm
procedure, pass(lv) :: setsv => mld_z_base_onelev_setsv
generic, public :: set => seti, setr, setc, &
& cseti, csetr, csetc, setsm, setsv
procedure, pass(lv) :: sizeof => z_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros
procedure, nopass :: stringval => mld_stringval
@ -213,7 +217,7 @@ module mld_z_onelev_mod
end interface
interface
subroutine mld_z_base_onelev_seti(lv,what,val,info)
subroutine mld_z_base_onelev_seti(lv,what,val,info,pos)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -224,11 +228,40 @@ module mld_z_onelev_mod
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_z_base_onelev_seti
end interface
interface
subroutine mld_z_base_onelev_setsm(lv,val,info,pos)
import :: psb_dpk_, mld_z_onelev_type, mld_z_base_smoother_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
Implicit None
! Arguments
class(mld_z_onelev_type), target, intent(inout) :: lv
class(mld_z_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_z_base_onelev_setsm
end interface
interface
subroutine mld_z_base_onelev_setc(lv,what,val,info)
subroutine mld_z_base_onelev_setsv(lv,val,info,pos)
import :: psb_dpk_, mld_z_onelev_type, mld_z_base_solver_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
Implicit None
! Arguments
class(mld_z_onelev_type), target, intent(inout) :: lv
class(mld_z_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_z_base_onelev_setsv
end interface
interface
subroutine mld_z_base_onelev_setc(lv,what,val,info,pos)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -238,11 +271,12 @@ module mld_z_onelev_mod
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_z_base_onelev_setc
end interface
interface
subroutine mld_z_base_onelev_setr(lv,what,val,info)
subroutine mld_z_base_onelev_setr(lv,what,val,info,pos)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -252,12 +286,13 @@ module mld_z_onelev_mod
integer(psb_ipk_), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_z_base_onelev_setr
end interface
interface
subroutine mld_z_base_onelev_cseti(lv,what,val,info)
subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -268,11 +303,12 @@ module mld_z_onelev_mod
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_z_base_onelev_cseti
end interface
interface
subroutine mld_z_base_onelev_csetc(lv,what,val,info)
subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -282,11 +318,12 @@ module mld_z_onelev_mod
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_z_base_onelev_csetc
end interface
interface
subroutine mld_z_base_onelev_csetr(lv,what,val,info)
subroutine mld_z_base_onelev_csetr(lv,what,val,info,pos)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, &
& psb_ipk_, psb_long_int_k_, psb_desc_type
@ -296,6 +333,7 @@ module mld_z_onelev_mod
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
end subroutine mld_z_base_onelev_csetr
end interface
@ -331,6 +369,8 @@ contains
val = 0
if (allocated(lv%sm)) &
& val = lv%sm%get_nzeros()
if (allocated(lv%sm2a)) &
& val = val + lv%sm2a%get_nzeros()
end function z_base_onelev_get_nzeros
function z_base_onelev_sizeof(lv) result(val)
@ -344,6 +384,7 @@ contains
val = val + lv%ac%sizeof()
val = val + lv%map%sizeof()
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
end function z_base_onelev_sizeof
@ -354,7 +395,7 @@ contains
nullify(lv%base_a)
nullify(lv%base_desc)
nullify(lv%sm2)
end subroutine z_base_onelev_nullify
!
@ -370,9 +411,9 @@ contains
subroutine z_base_onelev_default(lv)
Implicit None
! Arguments
class(mld_z_onelev_type), intent(inout) :: lv
class(mld_z_onelev_type), target, intent(inout) :: lv
lv%parms%sweeps = 1
lv%parms%sweeps_pre = 1
@ -390,6 +431,12 @@ contains
lv%parms%aggr_thresh = dzero
if (allocated(lv%sm)) call lv%sm%default()
if (allocated(lv%sm2a)) then
call lv%sm2a%default()
lv%sm2 => lv%sm2a
else
lv%sm2 => lv%sm
end if
return
@ -403,8 +450,8 @@ contains
! Arguments
class(mld_z_onelev_type), target, intent(inout) :: lv
class(mld_z_onelev_type), intent(inout) :: lvout
integer(psb_ipk_), intent(out) :: info
class(mld_z_onelev_type), target, intent(inout) :: lvout
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (allocated(lv%sm)) then
@ -415,6 +462,16 @@ contains
if (info==psb_success_) deallocate(lvout%sm,stat=info)
end if
end if
if (allocated(lv%sm2a)) then
call lv%sm%clone(lvout%sm2a,info)
lvout%sm2 => lvout%sm2a
else
if (allocated(lvout%sm2a)) then
call lvout%sm2a%free(info)
if (info==psb_success_) deallocate(lvout%sm2a,stat=info)
end if
lvout%sm2 => lvout%sm
end if
if (info == psb_success_) call lv%parms%clone(lvout%parms,info)
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
@ -430,12 +487,21 @@ contains
subroutine mld_z_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_z_onelev_type), intent(inout) :: a, b
type(mld_z_onelev_type), target, intent(inout) :: a, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (associated(a%sm2,a%sm2a)) then
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%sm2 =>b%sm2a
else
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%sm2 =>b%sm
end if
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)

41
mlprec/mld_z_prec_mod.f90
Unescape Escape View File

@ -91,74 +91,81 @@ module mld_z_prec_mod
contains
subroutine mld_z_iprecsetsm(p,val,info)
subroutine mld_z_iprecsetsm(p,val,info,pos)
type(mld_zprec_type), intent(inout) :: p
class(mld_z_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(val,info)
call p%set(val,info,pos=pos)
end subroutine mld_z_iprecsetsm
subroutine mld_z_iprecsetsv(p,val,info)
subroutine mld_z_iprecsetsv(p,val,info,pos)
type(mld_zprec_type), intent(inout) :: p
class(mld_z_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
call p%set(val,info)
character(len=*), optional, intent(in) :: pos
call p%set(val,info, pos=pos)
end subroutine mld_z_iprecsetsv
subroutine mld_z_iprecseti(p,what,val,info)
subroutine mld_z_iprecseti(p,what,val,info,pos)
type(mld_zprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_z_iprecseti
subroutine mld_z_iprecsetr(p,what,val,info)
subroutine mld_z_iprecsetr(p,what,val,info,pos)
type(mld_zprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_z_iprecsetr
subroutine mld_z_iprecsetc(p,what,val,info)
subroutine mld_z_iprecsetc(p,what,val,info,pos)
type(mld_zprec_type), intent(inout) :: p
integer(psb_ipk_), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_z_iprecsetc
subroutine mld_z_cprecseti(p,what,val,info)
subroutine mld_z_cprecseti(p,what,val,info,pos)
type(mld_zprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_z_cprecseti
subroutine mld_z_cprecsetr(p,what,val,info)
subroutine mld_z_cprecsetr(p,what,val,info,pos)
type(mld_zprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_z_cprecsetr
subroutine mld_z_cprecsetc(p,what,val,info)
subroutine mld_z_cprecsetc(p,what,val,info,pos)
type(mld_zprec_type), intent(inout) :: p
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
character(len=*), optional, intent(in) :: pos
call p%set(what,val,info)
call p%set(what,val,info,pos=pos)
end subroutine mld_z_cprecsetc
end module mld_z_prec_mod

42
mlprec/mld_z_prec_type.f90
Unescape Escape View File

@ -175,23 +175,25 @@ module mld_z_prec_type
end interface
interface
subroutine mld_zprecsetsm(prec,val,info,ilev)
subroutine mld_zprecsetsm(prec,val,info,ilev,pos)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& mld_zprec_type, mld_z_base_smoother_type, psb_ipk_
class(mld_zprec_type), intent(inout) :: prec
class(mld_zprec_type), target, intent(inout):: prec
class(mld_z_base_smoother_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_zprecsetsm
subroutine mld_zprecsetsv(prec,val,info,ilev)
subroutine mld_zprecsetsv(prec,val,info,ilev,pos)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& mld_zprec_type, mld_z_base_solver_type, psb_ipk_
class(mld_zprec_type), intent(inout) :: prec
class(mld_z_base_solver_type), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_zprecsetsv
subroutine mld_zprecseti(prec,what,val,info,ilev)
subroutine mld_zprecseti(prec,what,val,info,ilev,pos)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& mld_zprec_type, psb_ipk_
class(mld_zprec_type), intent(inout) :: prec
@ -199,8 +201,9 @@ module mld_z_prec_type
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_zprecseti
subroutine mld_zprecsetr(prec,what,val,info,ilev)
subroutine mld_zprecsetr(prec,what,val,info,ilev,pos)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& mld_zprec_type, psb_ipk_
class(mld_zprec_type), intent(inout) :: prec
@ -208,8 +211,9 @@ module mld_z_prec_type
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_zprecsetr
subroutine mld_zprecsetc(prec,what,string,info,ilev)
subroutine mld_zprecsetc(prec,what,string,info,ilev,pos)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& mld_zprec_type, psb_ipk_
class(mld_zprec_type), intent(inout) :: prec
@ -217,8 +221,9 @@ module mld_z_prec_type
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_zprecsetc
subroutine mld_zcprecseti(prec,what,val,info,ilev)
subroutine mld_zcprecseti(prec,what,val,info,ilev,pos)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& mld_zprec_type, psb_ipk_
class(mld_zprec_type), intent(inout) :: prec
@ -226,8 +231,9 @@ module mld_z_prec_type
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_zcprecseti
subroutine mld_zcprecsetr(prec,what,val,info,ilev)
subroutine mld_zcprecsetr(prec,what,val,info,ilev,pos)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& mld_zprec_type, psb_ipk_
class(mld_zprec_type), intent(inout) :: prec
@ -235,8 +241,9 @@ module mld_z_prec_type
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_zcprecsetr
subroutine mld_zcprecsetc(prec,what,string,info,ilev)
subroutine mld_zcprecsetc(prec,what,string,info,ilev,pos)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& mld_zprec_type, psb_ipk_
class(mld_zprec_type), intent(inout) :: prec
@ -244,6 +251,7 @@ module mld_z_prec_type
character(len=*), intent(in) :: string
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: ilev
character(len=*), optional, intent(in) :: pos
end subroutine mld_zcprecsetc
end interface
@ -477,6 +485,18 @@ contains
write(iout_,*)
return
end if
if (allocated(p%precv(1)%sm2a)) then
write(iout_,*) 'Post smoother details'
call p%precv(1)%sm2a%descr(info,iout=iout_)
if (nlev == 1) then
if (p%precv(1)%parms%sweeps > 1) then
write(iout_,*) ' Number of smoother sweeps : ',&
& p%precv(1)%parms%sweeps
end if
write(iout_,*)
return
end if
end if
end if
!

17
tests/fileread/df_sample.f90
Unescape Escape View File

@ -290,8 +290,8 @@ program df_sample
call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info)
call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info)
call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info)
call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info)
call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info)
call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info)
call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info)
call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info)
call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info)
call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info)
@ -299,18 +299,17 @@ program df_sample
call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info)
call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info)
call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info)
call mld_precset(prec,mld_ml_type_,'MULT',info)
call mld_precset(prec,mld_smoother_pos_,'TWOSIDE',info)
call mld_precset(prec,mld_coarse_sweeps_,4,info)
call mld_precset(prec,mld_coarse_sweeps_, 4, info)
call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info)
call mld_precset(prec,mld_coarse_mat_, prec_choice%cmat, info)
call mld_precset(prec,mld_coarse_fillin_, prec_choice%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prec_choice%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prec_choice%cjswp, info)
!!$ call prec%set(dbsmth,info,pos='post')
!!$ call prec%set(dbwgs,info,pos='post')
!!$ call mld_precset(prec,'solver_sweeps', 4, info, pos='pre')
!!$ call mld_precset(prec,'solver_sweeps', 4, info, pos='post')
call prec%set(dbsmth,info,pos='post')
call prec%set('sub_solve','gs',info,pos='post')
call prec%set('sub_solve','bwgs',info,pos='pre')
call mld_precset(prec,'solver_sweeps', 4, info, pos='pre')
call mld_precset(prec,'solver_sweeps', 4, info, pos='post')
else
nlv = 1
call mld_precinit(prec,prec_choice%prec,info)

18
tests/fileread/runs/dfs.inp
Unescape Escape View File

@ -1,7 +1,7 @@
DATIAMBRA/matrix.mm ! This matrix (and others) from: http://math.nist.gov/MatrixMarket/ or
DATIAMBRA/rhs.mm ! rhs | http://www.cise.ufl.edu/research/sparse/matrices/index.html
MM !
BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG
CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG
CSR ! Storage format: CSR COO JAD
0 ! IPART (partition method): 0 (block) 2 (graph, with Metis)
2 ! ISTOPC
@ -11,24 +11,24 @@ CSR ! Storage format: CSR COO JAD
1.d-6 ! EPS
5L-M-RAS-I-UR ! Longer descriptive name for preconditioner (up to 20 chars)
ML ! Preconditioner type: NONE JACOBI BJAC AS ML
1 ! Number of overlap layers for AS preconditioner
0 ! Number of overlap layers for AS preconditioner
HALO ! AS restriction operator: NONE HALO
NONE ! AS prolongation operator: NONE SUM AVG
ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS
GS ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS
0 ! Fill level P for ILU(P) and ILU(T,P)
1.d-4 ! Threshold T for ILU(T,P)
1 ! Number of Jacobi sweeps for base smoother
4 ! Number of Jacobi sweeps for base smoother
4 ! Number of levels in a multilevel preconditioner
AS ! Smoother type JACOBI BJAC AS ignored for non-ML
BJAC ! Smoother type JACOBI BJAC AS ignored for non-ML
SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED
DEC ! Type of aggregation: DEC
ADD ! Type of multilevel correction: ADD MULT
PRE ! Side of correction PRE POST TWOSIDE (ignored for ADD)
MULT ! Type of multilevel correction: ADD MULT
TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD)
DIST ! Coarsest-level matrix distribution: DIST REPL
BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU MUMPS SLUDIST
ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI)
GS ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI)
1 ! Coarsest-level fillin P for ILU(P) and ILU(T,P)
1.d-4 ! Coarsest-level threshold T for ILU(T,P)
2 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver
4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver
0.0125d0 ! Smoothed aggregation threshold: >= 0.0
0.5 ! Smoothed aggregation scaling factor.

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

@ -1,6 +1,6 @@
CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG
CSR ! Storage format CSR COO JAD
0040 ! IDIM; domain size is idim**3
0100 ! IDIM; domain size is idim**3
2 ! ISTOPC
2000 ! ITMAX
10 ! ITRACE
@ -15,7 +15,7 @@ GS ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU
4 ! Solver sweeps for GS
0 ! Level-set N for ILU(N), and P for ILUT
1.d-4 ! Threshold T for ILU(T,P)
2 ! Smoother/Jacobi sweeps
4 ! Smoother/Jacobi sweeps
BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML
2 ! Number of levels in a multilevel preconditioner
SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED, MINENERGY

Write Preview
Loading…
Cancel
Save