mirror of
https://github.com/sfilippone/amg4psblas.git
synced 2026-10-19 12:22:12 +00:00
mld2p4-smooth-twoside:
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.
This commit is contained in:
Salvatore Filippone
@@ -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
|
||||
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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,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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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,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
|
||||
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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,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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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,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
|
||||
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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,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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
+71
-376
@@ -76,7 +76,7 @@
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
subroutine mld_ccprecseti(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_prec_mod, mld_protect_name => mld_ccprecseti
|
||||
@@ -102,6 +102,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_
|
||||
@@ -144,38 +145,20 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
!
|
||||
! Rules for fine level are slightly different.
|
||||
!
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SMOOTHER_TYPE')
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case('SUB_SOLVE')
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
|
||||
& 'SMOOTHER_SWEEPS_POST',&
|
||||
& 'SUB_RESTR','SUB_PROL', &
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end select
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (ilev_ > 1) then
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SMOOTHER_TYPE')
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case('SUB_SOLVE')
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
|
||||
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
|
||||
& 'SMOOTHER_SWEEPS_POST',&
|
||||
& 'SUB_RESTR','SUB_PROL', &
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
|
||||
& 'COARSE_MAT')
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
case('COARSE_SUBSOLVE')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -184,7 +167,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
case('COARSE_SOLVE')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -192,38 +175,34 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),val,info)
|
||||
#if defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
|
||||
case(mld_sludist_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_,mld_mumps_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
|
||||
endif
|
||||
case('COARSE_SWEEPS')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -232,7 +211,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
|
||||
|
||||
case('COARSE_FILLIN')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -241,9 +220,10 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -254,33 +234,12 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
! levels
|
||||
!
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SUB_SOLVE')
|
||||
case('SUB_SOLVE','SUB_RESTR','SUB_PROL',&
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
|
||||
& 'SMOOTHER_SWEEPS','SMOOTHER_TYPE')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
if (.not.allocated(p%precv(ilev_)%sm)) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: uninitialized preconditioner component,',&
|
||||
& ' should call MLD_PRECINIT'
|
||||
info = -1
|
||||
return
|
||||
endif
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
|
||||
end do
|
||||
|
||||
case('SUB_RESTR','SUB_PROL',&
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case('SMOOTHER_SWEEPS')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case('SMOOTHER_TYPE')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
|
||||
@@ -288,334 +247,68 @@ subroutine mld_ccprecseti(p,what,val,info,ilev)
|
||||
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','AGGR_FILTER')
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
case('COARSE_MAT')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_MAT',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_SOLVE')
|
||||
if (nlev_ > 1) then
|
||||
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
#if defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
|
||||
case(mld_sludist_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_,mld_mumps_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
case('COARSE_SUBSOLVE')
|
||||
if (nlev_ > 1) then
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
endif
|
||||
|
||||
case('COARSE_SWEEPS')
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_FILLIN')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case default
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
contains
|
||||
|
||||
subroutine onelev_set_smoother(level,val,info)
|
||||
type(mld_c_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_noprec_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
type is (mld_c_base_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_c_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info ==0) allocate(mld_c_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_jac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_c_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_c_jac_smoother_type :: &
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_diag_solver_type :: &
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_bjac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_c_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_c_jac_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_as_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_c_as_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_c_as_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_as_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if (allocated(level%sm)) &
|
||||
& call level%sm%default()
|
||||
|
||||
end subroutine onelev_set_smoother
|
||||
|
||||
subroutine onelev_set_solver(level,val,info)
|
||||
type(mld_c_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_f_none_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_id_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_id_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_diag_scale_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_diag_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_diag_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_gs_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_gs_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_gs_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_gs_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm%sv)) then
|
||||
call level%sm%sv%default()
|
||||
else
|
||||
endif
|
||||
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_ilu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_ilu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
call level%sm%sv%set('SUB_SOLVE',val,info)
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
#ifdef HAVE_SLU_
|
||||
case (mld_slu_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_slu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_slu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_slu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case (mld_mumps_)
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_mumps_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_mumps_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_mumps_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
#endif
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
end subroutine onelev_set_solver
|
||||
|
||||
|
||||
end subroutine mld_ccprecseti
|
||||
|
||||
!
|
||||
@@ -657,7 +350,7 @@ end subroutine mld_ccprecseti
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_ccprecsetc(p,what,string,info,ilev)
|
||||
subroutine mld_ccprecsetc(p,what,string,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_prec_mod, mld_protect_name => mld_ccprecsetc
|
||||
@@ -670,6 +363,7 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev)
|
||||
character(len=*), intent(in) :: string
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_,val
|
||||
@@ -698,9 +392,9 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev)
|
||||
|
||||
val = mld_stringval(string)
|
||||
if (val >=0) then
|
||||
call p%set(what,val,info,ilev=ilev)
|
||||
call p%set(what,val,info,ilev=ilev,pos=pos)
|
||||
else
|
||||
call p%precv(ilev_)%set(what,string,info)
|
||||
call p%precv(ilev_)%set(what,string,info,pos=pos)
|
||||
end if
|
||||
|
||||
end subroutine mld_ccprecsetc
|
||||
@@ -744,7 +438,7 @@ end subroutine mld_ccprecsetc
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_ccprecsetr(p,what,val,info,ilev)
|
||||
subroutine mld_ccprecsetr(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_prec_mod, mld_protect_name => mld_ccprecsetr
|
||||
@@ -757,6 +451,7 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev)
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_,nlev_
|
||||
@@ -793,7 +488,7 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev)
|
||||
!
|
||||
if (present(ilev)) then
|
||||
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (.not.present(ilev)) then
|
||||
!
|
||||
@@ -803,19 +498,19 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev)
|
||||
select case(psb_toupper(what))
|
||||
case('COARSE_ILUTHRS')
|
||||
ilev_=nlev_
|
||||
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info)
|
||||
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
|
||||
|
||||
case('AGGR_THRESH')
|
||||
thr = val
|
||||
do ilev_ = 2, nlev_
|
||||
call p%precv(ilev_)%set('AGGR_THRESH',thr,info)
|
||||
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
|
||||
thr = thr * p%precv(ilev_)%parms%aggr_scale
|
||||
end do
|
||||
|
||||
case default
|
||||
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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.')
|
||||
|
||||
+74
-413
@@ -76,7 +76,7 @@
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
subroutine mld_cprecseti(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_prec_mod, mld_protect_name => mld_cprecseti
|
||||
@@ -101,6 +101,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_
|
||||
@@ -141,39 +142,21 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
if (present(ilev)) then
|
||||
|
||||
if (ilev_ == 1) then
|
||||
!
|
||||
! Rules for fine level are slightly different.
|
||||
!
|
||||
select case(what)
|
||||
case(mld_smoother_type_)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case(mld_sub_solve_)
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
|
||||
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
|
||||
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
|
||||
& mld_sub_restr_,mld_sub_prol_, &
|
||||
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end select
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (ilev_ > 1) then
|
||||
|
||||
select case(what)
|
||||
case(mld_smoother_type_)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case(mld_sub_solve_)
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
|
||||
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
|
||||
case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
|
||||
& mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
|
||||
& mld_aggr_kind_,mld_smoother_pos_,&
|
||||
& mld_aggr_omega_alg_,mld_aggr_eig_,&
|
||||
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
|
||||
& mld_sub_restr_,mld_sub_prol_, &
|
||||
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
|
||||
& mld_coarse_mat_)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
case(mld_coarse_subsolve_)
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -182,7 +165,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
case(mld_coarse_solve_)
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -192,30 +175,30 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
end if
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),val,info)
|
||||
#if defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_,mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -226,7 +209,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
|
||||
|
||||
case(mld_coarse_fillin_)
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -235,9 +218,9 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
|
||||
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -248,33 +231,12 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
! levels
|
||||
!
|
||||
select case(what)
|
||||
case(mld_sub_solve_)
|
||||
case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
|
||||
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
|
||||
& mld_smoother_sweeps_,mld_smoother_type_)
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
if (.not.allocated(p%precv(ilev_)%sm)) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: uninitialized preconditioner component,',&
|
||||
& ' should call MLD_PRECINIT'
|
||||
info = -1
|
||||
return
|
||||
endif
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
|
||||
end do
|
||||
|
||||
case(mld_sub_restr_,mld_sub_prol_,&
|
||||
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case(mld_smoother_sweeps_)
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case(mld_smoother_type_)
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,&
|
||||
@@ -282,336 +244,73 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
|
||||
& mld_smoother_pos_,mld_aggr_omega_alg_,&
|
||||
& mld_aggr_eig_,mld_aggr_filter_)
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
|
||||
case(mld_coarse_mat_)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case(mld_coarse_solve_)
|
||||
if (nlev_ > 1) then
|
||||
|
||||
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
#if defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
case(mld_coarse_subsolve_)
|
||||
if (nlev_ > 1) then
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
endif
|
||||
|
||||
case(mld_coarse_sweeps_)
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case(mld_coarse_fillin_)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
|
||||
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
|
||||
end if
|
||||
case default
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
contains
|
||||
|
||||
subroutine onelev_set_smoother(level,val,info)
|
||||
type(mld_c_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_noprec_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
type is (mld_c_base_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_c_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info ==0) allocate(mld_c_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_jac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_c_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_c_jac_smoother_type :: &
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_diag_solver_type :: &
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_bjac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_c_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_c_jac_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_as_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_c_as_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_c_as_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_as_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if (allocated(level%sm)) &
|
||||
& call level%sm%default()
|
||||
|
||||
end subroutine onelev_set_smoother
|
||||
|
||||
subroutine onelev_set_solver(level,val,info)
|
||||
type(mld_c_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_f_none_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_id_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_id_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
|
||||
case (mld_diag_scale_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_diag_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_diag_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_gs_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_gs_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_gs_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_gs_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm%sv)) then
|
||||
call level%sm%sv%default()
|
||||
end if
|
||||
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_ilu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_ilu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
call level%sm%sv%set(mld_sub_solve_,val,info)
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#ifdef HAVE_SLU_
|
||||
case (mld_slu_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_slu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_slu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_slu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case (mld_mumps_)
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_c_mumps_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_c_mumps_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_c_mumps_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
call level%sm%sv%default()
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
end subroutine onelev_set_solver
|
||||
|
||||
|
||||
end subroutine mld_cprecseti
|
||||
|
||||
subroutine mld_cprecsetsm(p,val,info,ilev)
|
||||
subroutine mld_cprecsetsm(p,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_prec_mod, mld_protect_name => mld_cprecsetsm
|
||||
@@ -623,6 +322,7 @@ subroutine mld_cprecsetsm(p,val,info,ilev)
|
||||
class(mld_c_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
|
||||
@@ -658,23 +358,13 @@ subroutine mld_cprecsetsm(p,val,info,ilev)
|
||||
|
||||
|
||||
do ilev_ = ilmin, ilmax
|
||||
if (allocated(p%precv(ilev_)%sm)) then
|
||||
if (allocated(p%precv(ilev_)%sm%sv)) then
|
||||
deallocate(p%precv(ilev_)%sm%sv)
|
||||
endif
|
||||
deallocate(p%precv(ilev_)%sm)
|
||||
end if
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(p%precv(ilev_)%sm,mold=val)
|
||||
#else
|
||||
allocate(p%precv(ilev_)%sm,source=val)
|
||||
#endif
|
||||
call p%precv(ilev_)%sm%default()
|
||||
call p%precv(ilev_)%set(val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
end subroutine mld_cprecsetsm
|
||||
|
||||
subroutine mld_cprecsetsv(p,val,info,ilev)
|
||||
subroutine mld_cprecsetsv(p,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_prec_mod, mld_protect_name => mld_cprecsetsv
|
||||
@@ -686,6 +376,7 @@ subroutine mld_cprecsetsv(p,val,info,ilev)
|
||||
class(mld_c_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
|
||||
@@ -720,43 +411,11 @@ subroutine mld_cprecsetsv(p,val,info,ilev)
|
||||
return
|
||||
endif
|
||||
|
||||
|
||||
do ilev_ = ilmin, ilmax
|
||||
if (allocated(p%precv(ilev_)%sm)) then
|
||||
if (allocated(p%precv(ilev_)%sm%sv)) then
|
||||
if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then
|
||||
deallocate(p%precv(ilev_)%sm%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(p%precv(ilev_)%sm%sv)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info)
|
||||
#else
|
||||
allocate(p%precv(ilev_)%sm%sv,source=val,stat=info)
|
||||
#endif
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
call p%precv(ilev_)%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call MLD_PRECINIT/MLD_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
call p%precv(ilev_)%set(val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
|
||||
|
||||
end subroutine mld_cprecsetsv
|
||||
|
||||
!
|
||||
@@ -798,7 +457,7 @@ end subroutine mld_cprecsetsv
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_cprecsetc(p,what,string,info,ilev)
|
||||
subroutine mld_cprecsetc(p,what,string,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_prec_mod, mld_protect_name => mld_cprecsetc
|
||||
@@ -811,6 +470,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev)
|
||||
character(len=*), intent(in) :: string
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_,val
|
||||
@@ -838,7 +498,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev)
|
||||
endif
|
||||
|
||||
val = mld_stringval(string)
|
||||
if (val >=0) call p%set(what,val,info,ilev=ilev)
|
||||
if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos)
|
||||
|
||||
|
||||
end subroutine mld_cprecsetc
|
||||
@@ -882,7 +542,7 @@ end subroutine mld_cprecsetc
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_cprecsetr(p,what,val,info,ilev)
|
||||
subroutine mld_cprecsetr(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_prec_mod, mld_protect_name => mld_cprecsetr
|
||||
@@ -895,6 +555,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_,nlev_
|
||||
@@ -931,7 +592,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
|
||||
!
|
||||
if (present(ilev)) then
|
||||
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (.not.present(ilev)) then
|
||||
!
|
||||
@@ -941,19 +602,19 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
|
||||
select case(what)
|
||||
case(mld_coarse_iluthrs_)
|
||||
ilev_=nlev_
|
||||
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info)
|
||||
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos)
|
||||
|
||||
case(mld_aggr_thresh_)
|
||||
thr = val
|
||||
do ilev_ = 2, nlev_
|
||||
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
|
||||
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos)
|
||||
thr = thr * p%precv(ilev_)%parms%aggr_scale
|
||||
end do
|
||||
|
||||
case default
|
||||
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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.')
|
||||
|
||||
@@ -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
|
||||
!
|
||||
|
||||
@@ -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_
|
||||
|
||||
+71
-376
@@ -76,7 +76,7 @@
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
subroutine mld_scprecseti(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_prec_mod, mld_protect_name => mld_scprecseti
|
||||
@@ -102,6 +102,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_
|
||||
@@ -144,38 +145,20 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
!
|
||||
! Rules for fine level are slightly different.
|
||||
!
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SMOOTHER_TYPE')
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case('SUB_SOLVE')
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
|
||||
& 'SMOOTHER_SWEEPS_POST',&
|
||||
& 'SUB_RESTR','SUB_PROL', &
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end select
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (ilev_ > 1) then
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SMOOTHER_TYPE')
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case('SUB_SOLVE')
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
|
||||
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
|
||||
& 'SMOOTHER_SWEEPS_POST',&
|
||||
& 'SUB_RESTR','SUB_PROL', &
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
|
||||
& 'COARSE_MAT')
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
case('COARSE_SUBSOLVE')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -184,7 +167,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
case('COARSE_SOLVE')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -192,38 +175,34 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),val,info)
|
||||
#if defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
|
||||
case(mld_sludist_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_,mld_mumps_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
|
||||
endif
|
||||
case('COARSE_SWEEPS')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -232,7 +211,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
|
||||
|
||||
case('COARSE_FILLIN')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -241,9 +220,10 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -254,33 +234,12 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
! levels
|
||||
!
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SUB_SOLVE')
|
||||
case('SUB_SOLVE','SUB_RESTR','SUB_PROL',&
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
|
||||
& 'SMOOTHER_SWEEPS','SMOOTHER_TYPE')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
if (.not.allocated(p%precv(ilev_)%sm)) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: uninitialized preconditioner component,',&
|
||||
& ' should call MLD_PRECINIT'
|
||||
info = -1
|
||||
return
|
||||
endif
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
|
||||
end do
|
||||
|
||||
case('SUB_RESTR','SUB_PROL',&
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case('SMOOTHER_SWEEPS')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case('SMOOTHER_TYPE')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
|
||||
@@ -288,334 +247,68 @@ subroutine mld_scprecseti(p,what,val,info,ilev)
|
||||
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','AGGR_FILTER')
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
case('COARSE_MAT')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_MAT',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_SOLVE')
|
||||
if (nlev_ > 1) then
|
||||
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
#if defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
|
||||
case(mld_sludist_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_,mld_mumps_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
case('COARSE_SUBSOLVE')
|
||||
if (nlev_ > 1) then
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
endif
|
||||
|
||||
case('COARSE_SWEEPS')
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_FILLIN')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case default
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
contains
|
||||
|
||||
subroutine onelev_set_smoother(level,val,info)
|
||||
type(mld_s_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_noprec_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
type is (mld_s_base_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_s_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info ==0) allocate(mld_s_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_jac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_s_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_s_jac_smoother_type :: &
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_diag_solver_type :: &
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_bjac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_s_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_s_jac_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_as_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_s_as_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_s_as_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_as_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if (allocated(level%sm)) &
|
||||
& call level%sm%default()
|
||||
|
||||
end subroutine onelev_set_smoother
|
||||
|
||||
subroutine onelev_set_solver(level,val,info)
|
||||
type(mld_s_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_f_none_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_id_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_id_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_diag_scale_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_diag_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_diag_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_gs_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_gs_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_gs_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_gs_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm%sv)) then
|
||||
call level%sm%sv%default()
|
||||
else
|
||||
endif
|
||||
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_ilu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_ilu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
call level%sm%sv%set('SUB_SOLVE',val,info)
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
#ifdef HAVE_SLU_
|
||||
case (mld_slu_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_slu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_slu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_slu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case (mld_mumps_)
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_mumps_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_mumps_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_mumps_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
#endif
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
end subroutine onelev_set_solver
|
||||
|
||||
|
||||
end subroutine mld_scprecseti
|
||||
|
||||
!
|
||||
@@ -657,7 +350,7 @@ end subroutine mld_scprecseti
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_scprecsetc(p,what,string,info,ilev)
|
||||
subroutine mld_scprecsetc(p,what,string,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_prec_mod, mld_protect_name => mld_scprecsetc
|
||||
@@ -670,6 +363,7 @@ subroutine mld_scprecsetc(p,what,string,info,ilev)
|
||||
character(len=*), intent(in) :: string
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_,val
|
||||
@@ -698,9 +392,9 @@ subroutine mld_scprecsetc(p,what,string,info,ilev)
|
||||
|
||||
val = mld_stringval(string)
|
||||
if (val >=0) then
|
||||
call p%set(what,val,info,ilev=ilev)
|
||||
call p%set(what,val,info,ilev=ilev,pos=pos)
|
||||
else
|
||||
call p%precv(ilev_)%set(what,string,info)
|
||||
call p%precv(ilev_)%set(what,string,info,pos=pos)
|
||||
end if
|
||||
|
||||
end subroutine mld_scprecsetc
|
||||
@@ -744,7 +438,7 @@ end subroutine mld_scprecsetc
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_scprecsetr(p,what,val,info,ilev)
|
||||
subroutine mld_scprecsetr(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_prec_mod, mld_protect_name => mld_scprecsetr
|
||||
@@ -757,6 +451,7 @@ subroutine mld_scprecsetr(p,what,val,info,ilev)
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_,nlev_
|
||||
@@ -793,7 +488,7 @@ subroutine mld_scprecsetr(p,what,val,info,ilev)
|
||||
!
|
||||
if (present(ilev)) then
|
||||
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (.not.present(ilev)) then
|
||||
!
|
||||
@@ -803,19 +498,19 @@ subroutine mld_scprecsetr(p,what,val,info,ilev)
|
||||
select case(psb_toupper(what))
|
||||
case('COARSE_ILUTHRS')
|
||||
ilev_=nlev_
|
||||
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info)
|
||||
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
|
||||
|
||||
case('AGGR_THRESH')
|
||||
thr = val
|
||||
do ilev_ = 2, nlev_
|
||||
call p%precv(ilev_)%set('AGGR_THRESH',thr,info)
|
||||
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
|
||||
thr = thr * p%precv(ilev_)%parms%aggr_scale
|
||||
end do
|
||||
|
||||
case default
|
||||
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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.')
|
||||
|
||||
+74
-413
@@ -76,7 +76,7 @@
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
subroutine mld_sprecseti(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_prec_mod, mld_protect_name => mld_sprecseti
|
||||
@@ -101,6 +101,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_
|
||||
@@ -141,39 +142,21 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
if (present(ilev)) then
|
||||
|
||||
if (ilev_ == 1) then
|
||||
!
|
||||
! Rules for fine level are slightly different.
|
||||
!
|
||||
select case(what)
|
||||
case(mld_smoother_type_)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case(mld_sub_solve_)
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
|
||||
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
|
||||
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
|
||||
& mld_sub_restr_,mld_sub_prol_, &
|
||||
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end select
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (ilev_ > 1) then
|
||||
|
||||
select case(what)
|
||||
case(mld_smoother_type_)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case(mld_sub_solve_)
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
|
||||
& mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,&
|
||||
case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,&
|
||||
& mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,&
|
||||
& mld_aggr_kind_,mld_smoother_pos_,&
|
||||
& mld_aggr_omega_alg_,mld_aggr_eig_,&
|
||||
& mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,&
|
||||
& mld_sub_restr_,mld_sub_prol_, &
|
||||
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
|
||||
& mld_coarse_mat_)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
case(mld_coarse_subsolve_)
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -182,7 +165,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
case(mld_coarse_solve_)
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -192,30 +175,30 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
end if
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),val,info)
|
||||
#if defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_,mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -226,7 +209,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
|
||||
|
||||
case(mld_coarse_fillin_)
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -235,9 +218,9 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
|
||||
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -248,33 +231,12 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
! levels
|
||||
!
|
||||
select case(what)
|
||||
case(mld_sub_solve_)
|
||||
case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
|
||||
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
|
||||
& mld_smoother_sweeps_,mld_smoother_type_)
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
if (.not.allocated(p%precv(ilev_)%sm)) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: uninitialized preconditioner component,',&
|
||||
& ' should call MLD_PRECINIT'
|
||||
info = -1
|
||||
return
|
||||
endif
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
|
||||
end do
|
||||
|
||||
case(mld_sub_restr_,mld_sub_prol_,&
|
||||
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_)
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case(mld_smoother_sweeps_)
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case(mld_smoother_type_)
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,&
|
||||
@@ -282,336 +244,73 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
|
||||
& mld_smoother_pos_,mld_aggr_omega_alg_,&
|
||||
& mld_aggr_eig_,mld_aggr_filter_)
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
|
||||
case(mld_coarse_mat_)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case(mld_coarse_solve_)
|
||||
if (nlev_ > 1) then
|
||||
|
||||
call p%precv(nlev_)%set(mld_coarse_solve_,val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
#if defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
case(mld_coarse_subsolve_)
|
||||
if (nlev_ > 1) then
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos)
|
||||
endif
|
||||
|
||||
case(mld_coarse_sweeps_)
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info)
|
||||
call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case(mld_coarse_fillin_)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set(mld_sub_fillin_,val,info)
|
||||
call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos)
|
||||
end if
|
||||
case default
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
contains
|
||||
|
||||
subroutine onelev_set_smoother(level,val,info)
|
||||
type(mld_s_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_noprec_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
type is (mld_s_base_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_s_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info ==0) allocate(mld_s_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_jac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_s_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_s_jac_smoother_type :: &
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_diag_solver_type :: &
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_bjac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_s_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_s_jac_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_as_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_s_as_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_s_as_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_as_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if (allocated(level%sm)) &
|
||||
& call level%sm%default()
|
||||
|
||||
end subroutine onelev_set_smoother
|
||||
|
||||
subroutine onelev_set_solver(level,val,info)
|
||||
type(mld_s_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_f_none_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_id_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_id_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
|
||||
case (mld_diag_scale_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_diag_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_diag_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_gs_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_gs_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_gs_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_gs_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm%sv)) then
|
||||
call level%sm%sv%default()
|
||||
end if
|
||||
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_ilu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_ilu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
call level%sm%sv%set(mld_sub_solve_,val,info)
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#ifdef HAVE_SLU_
|
||||
case (mld_slu_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_slu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_slu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_slu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case (mld_mumps_)
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_s_mumps_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_s_mumps_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_s_mumps_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
call level%sm%sv%default()
|
||||
end if
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
end subroutine onelev_set_solver
|
||||
|
||||
|
||||
end subroutine mld_sprecseti
|
||||
|
||||
subroutine mld_sprecsetsm(p,val,info,ilev)
|
||||
subroutine mld_sprecsetsm(p,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_prec_mod, mld_protect_name => mld_sprecsetsm
|
||||
@@ -623,6 +322,7 @@ subroutine mld_sprecsetsm(p,val,info,ilev)
|
||||
class(mld_s_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
|
||||
@@ -658,23 +358,13 @@ subroutine mld_sprecsetsm(p,val,info,ilev)
|
||||
|
||||
|
||||
do ilev_ = ilmin, ilmax
|
||||
if (allocated(p%precv(ilev_)%sm)) then
|
||||
if (allocated(p%precv(ilev_)%sm%sv)) then
|
||||
deallocate(p%precv(ilev_)%sm%sv)
|
||||
endif
|
||||
deallocate(p%precv(ilev_)%sm)
|
||||
end if
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(p%precv(ilev_)%sm,mold=val)
|
||||
#else
|
||||
allocate(p%precv(ilev_)%sm,source=val)
|
||||
#endif
|
||||
call p%precv(ilev_)%sm%default()
|
||||
call p%precv(ilev_)%set(val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
end subroutine mld_sprecsetsm
|
||||
|
||||
subroutine mld_sprecsetsv(p,val,info,ilev)
|
||||
subroutine mld_sprecsetsv(p,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_prec_mod, mld_protect_name => mld_sprecsetsv
|
||||
@@ -686,6 +376,7 @@ subroutine mld_sprecsetsv(p,val,info,ilev)
|
||||
class(mld_s_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax
|
||||
@@ -720,43 +411,11 @@ subroutine mld_sprecsetsv(p,val,info,ilev)
|
||||
return
|
||||
endif
|
||||
|
||||
|
||||
do ilev_ = ilmin, ilmax
|
||||
if (allocated(p%precv(ilev_)%sm)) then
|
||||
if (allocated(p%precv(ilev_)%sm%sv)) then
|
||||
if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then
|
||||
deallocate(p%precv(ilev_)%sm%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(p%precv(ilev_)%sm%sv)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info)
|
||||
#else
|
||||
allocate(p%precv(ilev_)%sm%sv,source=val,stat=info)
|
||||
#endif
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
call p%precv(ilev_)%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call MLD_PRECINIT/MLD_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
call p%precv(ilev_)%set(val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
|
||||
|
||||
end subroutine mld_sprecsetsv
|
||||
|
||||
!
|
||||
@@ -798,7 +457,7 @@ end subroutine mld_sprecsetsv
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_sprecsetc(p,what,string,info,ilev)
|
||||
subroutine mld_sprecsetc(p,what,string,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_prec_mod, mld_protect_name => mld_sprecsetc
|
||||
@@ -811,6 +470,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev)
|
||||
character(len=*), intent(in) :: string
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_,val
|
||||
@@ -838,7 +498,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev)
|
||||
endif
|
||||
|
||||
val = mld_stringval(string)
|
||||
if (val >=0) call p%set(what,val,info,ilev=ilev)
|
||||
if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos)
|
||||
|
||||
|
||||
end subroutine mld_sprecsetc
|
||||
@@ -882,7 +542,7 @@ end subroutine mld_sprecsetc
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_sprecsetr(p,what,val,info,ilev)
|
||||
subroutine mld_sprecsetr(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_prec_mod, mld_protect_name => mld_sprecsetr
|
||||
@@ -895,6 +555,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_,nlev_
|
||||
@@ -931,7 +592,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
|
||||
!
|
||||
if (present(ilev)) then
|
||||
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (.not.present(ilev)) then
|
||||
!
|
||||
@@ -941,19 +602,19 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
|
||||
select case(what)
|
||||
case(mld_coarse_iluthrs_)
|
||||
ilev_=nlev_
|
||||
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info)
|
||||
call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos)
|
||||
|
||||
case(mld_aggr_thresh_)
|
||||
thr = val
|
||||
do ilev_ = 2, nlev_
|
||||
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
|
||||
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos)
|
||||
thr = thr * p%precv(ilev_)%parms%aggr_scale
|
||||
end do
|
||||
|
||||
case default
|
||||
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
|
||||
+73
-428
@@ -76,7 +76,7 @@
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
subroutine mld_zcprecseti(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_z_prec_mod, mld_protect_name => mld_zcprecseti
|
||||
@@ -108,6 +108,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_
|
||||
@@ -150,38 +151,20 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
!
|
||||
! Rules for fine level are slightly different.
|
||||
!
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SMOOTHER_TYPE')
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case('SUB_SOLVE')
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
|
||||
& 'SMOOTHER_SWEEPS_POST',&
|
||||
& 'SUB_RESTR','SUB_PROL', &
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end select
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (ilev_ > 1) then
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SMOOTHER_TYPE')
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
case('SUB_SOLVE')
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',&
|
||||
& 'ML_TYPE','AGGR_ALG','AGGR_ORD',&
|
||||
& 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',&
|
||||
& 'SMOOTHER_SWEEPS_POST',&
|
||||
& 'SUB_RESTR','SUB_PROL', &
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
|
||||
& 'COARSE_MAT')
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
case('COARSE_SUBSOLVE')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -190,7 +173,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
case('COARSE_SOLVE')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -198,40 +181,36 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_umf_,info)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
|
||||
case(mld_sludist_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_,mld_mumps_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
|
||||
endif
|
||||
case('COARSE_SWEEPS')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -240,7 +219,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
|
||||
|
||||
case('COARSE_FILLIN')
|
||||
if (ilev_ /= nlev_) then
|
||||
@@ -249,9 +228,10 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
|
||||
case default
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -262,33 +242,12 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
! levels
|
||||
!
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SUB_SOLVE')
|
||||
case('SUB_SOLVE','SUB_RESTR','SUB_PROL',&
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN',&
|
||||
& 'SMOOTHER_SWEEPS','SMOOTHER_TYPE')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
if (.not.allocated(p%precv(ilev_)%sm)) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: uninitialized preconditioner component,',&
|
||||
& ' should call MLD_PRECINIT'
|
||||
info = -1
|
||||
return
|
||||
endif
|
||||
call onelev_set_solver(p%precv(ilev_),val,info)
|
||||
|
||||
end do
|
||||
|
||||
case('SUB_RESTR','SUB_PROL',&
|
||||
& 'SUB_REN','SUB_OVR','SUB_FILLIN')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case('SMOOTHER_SWEEPS')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
end do
|
||||
|
||||
case('SMOOTHER_TYPE')
|
||||
do ilev_=1,max(1,nlev_-1)
|
||||
call onelev_set_smoother(p%precv(ilev_),val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',&
|
||||
@@ -296,386 +255,70 @@ subroutine mld_zcprecseti(p,what,val,info,ilev)
|
||||
& 'SMOOTHER_POS','AGGR_OMEGA_ALG',&
|
||||
& 'AGGR_EIG','AGGR_FILTER')
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
if (info /= 0) return
|
||||
end do
|
||||
|
||||
case('COARSE_MAT')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_MAT',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_SOLVE')
|
||||
if (nlev_ > 1) then
|
||||
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info)
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_umf_,info)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_slu_,info)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_mumps_,info)
|
||||
#else
|
||||
call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info)
|
||||
case(mld_sludist_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_mumps_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_sludist_,mld_mumps_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_jac_)
|
||||
call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info)
|
||||
call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
case('COARSE_SUBSOLVE')
|
||||
if (nlev_ > 1) then
|
||||
call onelev_set_solver(p%precv(nlev_),val,info)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
endif
|
||||
|
||||
case('COARSE_SWEEPS')
|
||||
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info)
|
||||
call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_FILLIN')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case default
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
endif
|
||||
|
||||
contains
|
||||
|
||||
subroutine onelev_set_smoother(level,val,info)
|
||||
type(mld_z_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_noprec_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
type is (mld_z_base_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_z_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_z_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_base_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info ==0) allocate(mld_z_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_jac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_z_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_z_jac_smoother_type :: &
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_z_diag_solver_type :: &
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_z_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_bjac_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_z_jac_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_z_jac_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_z_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_jac_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_z_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case (mld_as_)
|
||||
if (allocated(level%sm)) then
|
||||
select type (sm => level%sm)
|
||||
class is (mld_z_as_smoother_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm)
|
||||
if (info == 0) allocate(mld_z_as_smoother_type ::&
|
||||
& level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_z_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_as_smoother_type :: level%sm, stat=info)
|
||||
if (info == 0) allocate(mld_z_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
endif
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if (allocated(level%sm)) &
|
||||
& call level%sm%default()
|
||||
|
||||
end subroutine onelev_set_smoother
|
||||
|
||||
subroutine onelev_set_solver(level,val,info)
|
||||
type(mld_z_onelev_type), intent(inout) :: level
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
info = psb_success_
|
||||
|
||||
!
|
||||
! This here requires a bit more attention.
|
||||
!
|
||||
select case (val)
|
||||
case (mld_f_none_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_z_id_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_z_id_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_id_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_diag_scale_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_z_diag_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_z_diag_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_diag_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_gs_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_z_gs_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_z_gs_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_gs_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm%sv)) then
|
||||
call level%sm%sv%default()
|
||||
else
|
||||
endif
|
||||
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_z_ilu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_z_ilu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_ilu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
call level%sm%sv%set('SUB_SOLVE',val,info)
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
|
||||
#ifdef HAVE_SLU_
|
||||
case (mld_slu_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_z_slu_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_z_slu_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_slu_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case (mld_mumps_)
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_z_mumps_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_z_mumps_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_mumps_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
#endif
|
||||
|
||||
#ifdef HAVE_UMF_
|
||||
case (mld_umf_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_z_umf_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_z_umf_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_umf_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#endif
|
||||
#ifdef HAVE_SLUDIST_
|
||||
case (mld_sludist_)
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) then
|
||||
select type (sv => level%sm%sv)
|
||||
class is (mld_z_sludist_solver_type)
|
||||
! do nothing
|
||||
class default
|
||||
call level%sm%sv%free(info)
|
||||
if (info == 0) deallocate(level%sm%sv)
|
||||
if (info == 0) allocate(mld_z_sludist_solver_type ::&
|
||||
& level%sm%sv, stat=info)
|
||||
end select
|
||||
else
|
||||
allocate(mld_z_sludist_solver_type :: level%sm%sv, stat=info)
|
||||
endif
|
||||
if (allocated(level%sm)) then
|
||||
if (allocated(level%sm%sv)) &
|
||||
& call level%sm%sv%default()
|
||||
end if
|
||||
else
|
||||
write(0,*) 'Calling set_solver without a smoother?'
|
||||
info = -5
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
end subroutine onelev_set_solver
|
||||
|
||||
|
||||
end subroutine mld_zcprecseti
|
||||
|
||||
!
|
||||
@@ -717,7 +360,7 @@ end subroutine mld_zcprecseti
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_zcprecsetc(p,what,string,info,ilev)
|
||||
subroutine mld_zcprecsetc(p,what,string,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_z_prec_mod, mld_protect_name => mld_zcprecsetc
|
||||
@@ -730,6 +373,7 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev)
|
||||
character(len=*), intent(in) :: string
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_, nlev_,val
|
||||
@@ -758,9 +402,9 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev)
|
||||
|
||||
val = mld_stringval(string)
|
||||
if (val >=0) then
|
||||
call p%set(what,val,info,ilev=ilev)
|
||||
call p%set(what,val,info,ilev=ilev,pos=pos)
|
||||
else
|
||||
call p%precv(ilev_)%set(what,string,info)
|
||||
call p%precv(ilev_)%set(what,string,info,pos=pos)
|
||||
end if
|
||||
|
||||
end subroutine mld_zcprecsetc
|
||||
@@ -804,7 +448,7 @@ end subroutine mld_zcprecsetc
|
||||
! For this reason, the interface mld_precset to this routine has been built in
|
||||
! such a way that ilev is not visible to the user (see mld_prec_mod.f90).
|
||||
!
|
||||
subroutine mld_zcprecsetr(p,what,val,info,ilev)
|
||||
subroutine mld_zcprecsetr(p,what,val,info,ilev,pos)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_z_prec_mod, mld_protect_name => mld_zcprecsetr
|
||||
@@ -817,6 +461,7 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev)
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), optional, intent(in) :: ilev
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev_,nlev_
|
||||
@@ -853,7 +498,7 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev)
|
||||
!
|
||||
if (present(ilev)) then
|
||||
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
|
||||
else if (.not.present(ilev)) then
|
||||
!
|
||||
@@ -863,19 +508,19 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev)
|
||||
select case(psb_toupper(what))
|
||||
case('COARSE_ILUTHRS')
|
||||
ilev_=nlev_
|
||||
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info)
|
||||
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
|
||||
|
||||
case('AGGR_THRESH')
|
||||
thr = val
|
||||
do ilev_ = 2, nlev_
|
||||
call p%precv(ilev_)%set('AGGR_THRESH',thr,info)
|
||||
call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos)
|
||||
thr = thr * p%precv(ilev_)%parms%aggr_scale
|
||||
end do
|
||||
|
||||
case default
|
||||
|
||||
do ilev_=1,nlev_
|
||||
call p%precv(ilev_)%set(what,val,info)
|
||||
call p%precv(ilev_)%set(what,val,info,pos=pos)
|
||||
end do
|
||||
end select
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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.')
|
||||
|
||||
+74
-461
@@ -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
|
||||
|
||||
|
||||
@@ -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 \
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -182,7 +182,6 @@
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
#else
|
||||
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
|
||||
#endif
|
||||
|
||||
@@ -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')
|
||||
|
||||
+107
-11
@@ -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
|
||||
|
||||
+81
-15
@@ -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)
|
||||
|
||||
+24
-17
@@ -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
|
||||
|
||||
+31
-11
@@ -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
|
||||
|
||||
!
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
+107
-11
@@ -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
|
||||
|
||||
+81
-15
@@ -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)
|
||||
|
||||
+24
-17
@@ -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
|
||||
|
||||
+31
-11
@@ -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
|
||||
|
||||
!
|
||||
|
||||
+107
-11
@@ -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
|
||||
|
||||
+81
-15
@@ -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)
|
||||
|
||||
+24
-17
@@ -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
|
||||
|
||||
+31
-11
@@ -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
|
||||
|
||||
!
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user