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

mld2p4-smoother-2side:

Browse Source 
mlprec/impl/mld_dmlprec_aply.f90
 mlprec/impl/mld_dmlprec_bld.f90
 mlprec/mld_d_gs_solver.f90
 mlprec/mld_d_onelev_mod.f90
 tests/pdegen/runs/ppde.inp

First steps towards BW-gs as a 2nd smoother.
stopcriterion
Salvatore Filippone 9 years ago
parent 51fa5ef069
commit 6f06a48d25
5 changed files with 168 additions and 41 deletions
Show Stats Download Patch File Download Diff File

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

@ -406,7 +406,7 @@ contains
! Arguments ! Arguments
integer(psb_ipk_) :: level integer(psb_ipk_) :: level
type(mld_dprec_type), intent(inout) :: p type(mld_dprec_type), target, intent(inout) :: p
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
character, intent(in) :: trans character, intent(in) :: trans
real(psb_dpk_),target :: work(:) real(psb_dpk_),target :: work(:)
@ -539,7 +539,6 @@ contains
end if end if
! This is one step of post-smoothing ! This is one step of post-smoothing
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -572,7 +571,7 @@ contains
end if end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
@ -583,8 +582,9 @@ contains
end if end if
else else
! Here at coarse level
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
@ -624,7 +624,7 @@ contains
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
end if end if
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
@ -830,6 +830,13 @@ contains
case(mld_twoside_smooth_) 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() nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows() nr2l = p%precv(level)%base_desc%get_local_rows()
allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info)
@ -866,10 +873,19 @@ contains
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
end if end if
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm%apply(done,& if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
else
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)
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply') & a_err='Error during smoother_apply')
@ -930,10 +946,18 @@ contains
else else
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
end if end if
if (trans == 'N') then
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)
else
if (info == psb_success_) call p%precv(level)%sm%apply(done,& if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply') & a_err='Error during smoother_apply')
@ -1043,7 +1067,7 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
level = 1 level = 1
call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info)
call mlprec_wrk(level)%vy2l%set(dzero) call mlprec_wrk(level)%vy2l%zero()
call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info)
@ -1122,7 +1146,9 @@ contains
nc2l = p%precv(level)%base_desc%get_local_cols() nc2l = p%precv(level)%base_desc%get_local_cols()
nr2l = p%precv(level)%base_desc%get_local_rows() 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) select case(p%precv(level)%parms%ml_type)
@ -1250,7 +1276,7 @@ contains
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%vx2l,done,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,done,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
@ -1262,7 +1288,7 @@ contains
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
@ -1302,7 +1328,7 @@ contains
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
end if end if
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
@ -1536,13 +1562,20 @@ contains
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
end if end if
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm%apply(done,& if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
else
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply') & a_err='Error during 1st smoother_apply')
goto 9999 goto 9999
end if end if
@ -1605,13 +1638,20 @@ contains
else else
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
end if end if
if (trans == 'N') then
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,&
& sweeps,work,info)
else
if (info == psb_success_) call p%precv(level)%sm%apply(done,& if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply') & a_err='Error during 2nd smoother_apply')
goto 9999 goto 9999
end if end if

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

@ -495,7 +495,7 @@ 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,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold,imold=imold) & 'F',info,amold=amold,vmold=vmold,imold=imold)
p%precv(i)%sm2 => p%precv(i)%sm
if ((info == psb_success_).and.(i>1)) then if ((info == psb_success_).and.(i>1)) then
call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
end if end if

66
mlprec/mld_d_gs_solver.f90
Unescape Escape View File

@ -74,6 +74,16 @@ module mld_d_gs_solver
procedure, nopass :: is_iterative => d_gs_solver_is_iterative procedure, nopass :: is_iterative => d_gs_solver_is_iterative
end type mld_d_gs_solver_type end type mld_d_gs_solver_type
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
end type mld_d_bwgs_solver_type
private :: d_gs_solver_bld, d_gs_solver_apply, & private :: d_gs_solver_bld, d_gs_solver_apply, &
& d_gs_solver_free, d_gs_solver_seti, & & d_gs_solver_free, d_gs_solver_seti, &
@ -82,7 +92,8 @@ module mld_d_gs_solver
& d_gs_solver_default, d_gs_solver_dmp, & & d_gs_solver_default, d_gs_solver_dmp, &
& d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, &
& d_gs_solver_get_fmt, d_gs_solver_check,& & d_gs_solver_get_fmt, d_gs_solver_check,&
& d_gs_solver_is_iterative & d_gs_solver_is_iterative, &
& d_bwgs_solver_get_fmt, d_bwgs_solver_descr
interface interface
@ -452,10 +463,10 @@ contains
endif endif
if (sv%eps<=dzero) then if (sv%eps<=dzero) then
write(iout_,*) ' Gauss-Seidel iterative solver with ',& write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',&
& sv%sweeps,' sweeps' & sv%sweeps,' sweeps'
else else
write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps & sv%eps,' and maxit', sv%sweeps
end if end if
@ -500,7 +511,7 @@ contains
implicit none implicit none
character(len=32) :: val character(len=32) :: val
val = "Gauss-Seidel solver" val = "Forward Gauss-Seidel solver"
end function d_gs_solver_get_fmt end function d_gs_solver_get_fmt
@ -515,4 +526,51 @@ contains
val = .true. val = .true.
end function d_gs_solver_is_iterative end function d_gs_solver_is_iterative
subroutine d_bwgs_solver_descr(sv,info,iout,coarse)
Implicit None
! Arguments
class(mld_d_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_d_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 d_bwgs_solver_descr
function d_bwgs_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Backward Gauss-Seidel solver"
end function d_bwgs_solver_get_fmt
end module mld_d_gs_solver end module mld_d_gs_solver

39
mlprec/mld_d_onelev_mod.f90
Unescape Escape View File

@ -121,7 +121,8 @@ module mld_d_onelev_mod
! !
! !
type mld_d_onelev_type type mld_d_onelev_type
class(mld_d_base_smoother_type), allocatable :: sm class(mld_d_base_smoother_type), allocatable :: sm, sm2a
class(mld_d_base_smoother_type), pointer :: sm2
type(mld_dml_parms) :: parms type(mld_dml_parms) :: parms
type(psb_dspmat_type) :: ac type(psb_dspmat_type) :: ac
integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot
@ -331,6 +332,8 @@ contains
val = 0 val = 0
if (allocated(lv%sm)) & if (allocated(lv%sm)) &
& val = lv%sm%get_nzeros() & val = lv%sm%get_nzeros()
if (allocated(lv%sm2a)) &
& val = val + lv%sm2a%get_nzeros()
end function d_base_onelev_get_nzeros end function d_base_onelev_get_nzeros
function d_base_onelev_sizeof(lv) result(val) function d_base_onelev_sizeof(lv) result(val)
@ -343,6 +346,7 @@ contains
val = val + lv%ac%sizeof() val = val + lv%ac%sizeof()
val = val + lv%map%sizeof() val = val + lv%map%sizeof()
if (allocated(lv%sm)) val = val + lv%sm%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof()
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
end function d_base_onelev_sizeof end function d_base_onelev_sizeof
@ -353,7 +357,7 @@ contains
nullify(lv%base_a) nullify(lv%base_a)
nullify(lv%base_desc) nullify(lv%base_desc)
nullify(lv%sm2)
end subroutine d_base_onelev_nullify end subroutine d_base_onelev_nullify
! !
@ -371,7 +375,7 @@ contains
Implicit None Implicit None
! Arguments ! Arguments
class(mld_d_onelev_type), intent(inout) :: lv class(mld_d_onelev_type), target, intent(inout) :: lv
lv%parms%sweeps = 1 lv%parms%sweeps = 1
lv%parms%sweeps_pre = 1 lv%parms%sweeps_pre = 1
@ -388,6 +392,12 @@ contains
lv%parms%aggr_thresh = dzero lv%parms%aggr_thresh = dzero
if (allocated(lv%sm)) call lv%sm%default() 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 return
@ -401,7 +411,7 @@ contains
! Arguments ! Arguments
class(mld_d_onelev_type), target, intent(inout) :: lv class(mld_d_onelev_type), target, intent(inout) :: lv
class(mld_d_onelev_type), intent(inout) :: lvout class(mld_d_onelev_type), target, intent(inout) :: lvout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
info = psb_success_ info = psb_success_
@ -413,6 +423,16 @@ contains
if (info==psb_success_) deallocate(lvout%sm,stat=info) if (info==psb_success_) deallocate(lvout%sm,stat=info)
end if end if
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%parms%clone(lvout%parms,info)
if (info == psb_success_) call lv%ac%clone(lvout%ac,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) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
@ -428,12 +448,21 @@ contains
subroutine mld_d_onelev_move_alloc(a, b,info) subroutine mld_d_onelev_move_alloc(a, b,info)
use psb_base_mod use psb_base_mod
implicit none implicit none
type(mld_d_onelev_type), intent(inout) :: a, b type(mld_d_onelev_type), target, intent(inout) :: a, b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call b%free(info) call b%free(info)
b%parms = a%parms b%parms = a%parms
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%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%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%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)

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

@ -3,7 +3,7 @@ CSR ! Storage format CSR COO JAD
0100 ! IDIM; domain size is idim**3 0100 ! IDIM; domain size is idim**3
2 ! ISTOPC 2 ! ISTOPC
0100 ! ITMAX 0100 ! ITMAX
1 ! ITRACE 10 ! ITRACE
30 ! IRST (restart for RGMRES and BiCGSTABL) 30 ! IRST (restart for RGMRES and BiCGSTABL)
1.d-6 ! EPS 1.d-6 ! EPS
3L-MUL-RAS-BJAC4-ILU ! Descriptive name for preconditioner (up to 40 chars) 3L-MUL-RAS-BJAC4-ILU ! Descriptive name for preconditioner (up to 40 chars)
@ -12,7 +12,7 @@ ML ! Preconditioner NONE JACOBI BJAC AS ML
HALO ! Restriction operator NONE HALO HALO ! Restriction operator NONE HALO
NONE ! Prolongation operator NONE SUM AVG NONE ! Prolongation operator NONE SUM AVG
GS ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU GS ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU
1 ! sweeps for GS 2 ! sweeps for GS
0 ! Level-set N for ILU(N), and P for ILUT 0 ! Level-set N for ILU(N), and P for ILUT
1.d-4 ! Threshold T for ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P)
1 ! Smoother/Jacobi sweeps 1 ! Smoother/Jacobi sweeps

Write Preview
Loading…
Cancel
Save