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

New Jacobi implementation.

Browse Source
stopcriterion
Salvatore Filippone 6 years ago
parent 19d33fae2c
commit b2047f95e0
24 changed files with 1076 additions and 544 deletions
Show Stats Download Patch File Download Diff File

173
mlprec/impl/smoother/mld_c_jac_smoother_apply.f90
Unescape Escape View File

@ -114,73 +114,134 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
endif endif
else if (sweeps >= 0) then else if (sweeps >= 0) then
! if (associated(sm%pa)) then
! !
! Apply multiple sweeps of a block-Jacobi solver ! This means we are dealing with a pure Jacobi smoother/solver.
! to compute an approximate solution of a linear system. !
! call psb_geasb(tx,desc_data,info)
! call psb_geasb(ty,desc_data,info)
call psb_geasb(tx,desc_data,info) select case (init_)
call psb_geasb(ty,desc_data,info) case('Z')
! call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z')
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be case('Y')
! significant when sweeps=1 (a common case) call psb_geaxpby(cone,x,czero,tx,desc_data,info)
! call psb_geaxpby(cone,y,czero,ty,desc_data,info)
select case (init_) call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
case('Z') call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z') case('U')
if (.not.present(initu)) then
case('Y') call psb_errpush(psb_err_internal_error_,name,&
call psb_geaxpby(cone,x,czero,tx,desc_data,info) & a_err='missing initu to smoother_apply')
call psb_geaxpby(cone,y,czero,ty,desc_data,info) goto 9999
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) end if
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
case('U') call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
if (.not.present(initu)) then call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply') & a_err='wrong init to smoother_apply')
goto 9999 goto 9999
end select
do i=1, sweeps-1
!
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
! where is the diagonal and A the matrix.
!
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if end if
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,initu,czero,ty,desc_data,info) else
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) !
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') !
! Apply multiple sweeps of a block-Jacobi solver
case default ! to compute an approximate solution of a linear system.
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
do i=1, sweeps-1
! !
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! !
call psb_geaxpby(cone,x,czero,tx,desc_data,info) call psb_geasb(tx,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) call psb_geasb(ty,desc_data,info)
if (info /= psb_success_) exit !
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
select case (init_)
case('Z')
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z')
if (info /= psb_success_) exit case('Y')
end do call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) then case default
info=psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,&
call psb_errpush(info,name,& & a_err='wrong init to smoother_apply')
& a_err='subsolve with Jacobi sweeps > 1') goto 9999
goto 9999 end select
end if
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end if
deallocate(tx,ty,stat=info) deallocate(tx,ty,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_

175
mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -115,80 +115,143 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
goto 9999 goto 9999
endif endif
else if (sweeps >= 0) then else if (sweeps >= 0) then
! if (associated(sm%pa)) then
!
! Apply multiple sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2))
! !
! Unroll the first iteration and fold it inside SELECT CASE ! This means we are dealing with a pure Jacobi smoother/solver.
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
! !
select case (init_) associate(tx => wv(1), ty => wv(2))
case('Z') select case (init_)
case('Z')
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y')
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('Y') case('U')
call psb_geaxpby(cone,x,czero,tx,desc_data,info) if (.not.present(initu)) then
call psb_geaxpby(cone,y,czero,ty,desc_data,info) call psb_errpush(psb_err_internal_error_,name,&
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) & a_err='missing initu to smoother_apply')
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') goto 9999
end if
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('U') case default
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply') & a_err='wrong init to smoother_apply')
goto 9999 goto 9999
end select
do i=1, sweeps-1
!
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
! where is the diagonal and A the matrix.
!
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if end if
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) end associate
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
else
case default !
call psb_errpush(psb_err_internal_error_,name,& !
& a_err='wrong init to smoother_apply') ! Apply multiple sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999 goto 9999
end select end if
associate(tx => wv(1), ty => wv(2))
do i=1, sweeps-1
! !
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the ! Unroll the first iteration and fold it inside SELECT CASE
! block diagonal part and the remaining part of the local matrix ! this will save one AXPBY and one SPMM when INIT=Z, and will be
! and Y(j) is the approximate solution at sweep j. ! significant when sweeps=1 (a common case)
! !
call psb_geaxpby(cone,x,czero,tx,desc_data,info) select case (init_)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) case('Z')
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
if (info /= psb_success_) exit case('Y')
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit case default
end do call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) then if (info /= psb_success_) exit
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate
end if
else else

32
mlprec/impl/smoother/mld_c_jac_smoother_bld.f90
Unescape Escape View File

@ -71,26 +71,33 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
nrow_a = a%get_nrows() nrow_a = a%get_nrows()
nztota = a%get_nzeros() nztota = a%get_nzeros()
select type (smsv => sm%sv) select type (smsv => sm%sv)
type is (mld_c_diag_solver_type) class is (mld_c_diag_solver_type)
call a%clip_diag(sm%nd,info) call sm%nd%free()
sm%pa => a
sm%nnz_nd_tot = nztota
class default class default
call a%csclip(sm%nd,info,& call a%csclip(sm%nd,info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.) & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
if (info == psb_success_) then
if (present(amold)) then
call sm%nd%cscnv(info,&
& mold=amold,dupl=psb_dupl_add_)
else
call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
endif
end if
sm%nnz_nd_tot = sm%nd%get_nzeros()
end select end select
if (info == psb_success_) then
if (present(amold)) then
call sm%nd%cscnv(info,&
& mold=amold,dupl=psb_dupl_add_)
else
call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
endif
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,& call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='clip & psb_spcnv csr 4') & a_err='clip & psb_spcnv csr 4')
goto 9999 goto 9999
end if end if
call psb_sum(ictxt,sm%nnz_nd_tot)
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -98,9 +105,6 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
& a_err='solver build') & a_err='solver build')
goto 9999 goto 9999
end if end if
nzeros = sm%nd%get_nzeros()
call psb_sum(ictxt,nzeros)
sm%nnz_nd_tot = nzeros
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end' & write(debug_unit,*) me,' ',trim(name),' end'

18
mlprec/impl/smoother/mld_c_jac_smoother_cnv.f90
Unescape Escape View File

@ -58,14 +58,16 @@ subroutine mld_c_jac_smoother_cnv(sm,info,amold,vmold,imold)
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
if (info == psb_success_) then if (info == psb_success_) then
if (present(amold)) then if (.not.associated(sm%pa)) then
call sm%nd%cscnv(info,& if (present(amold)) then
& mold=amold,dupl=psb_dupl_add_) call sm%nd%cscnv(info,&
else & mold=amold,dupl=psb_dupl_add_)
call sm%nd%cscnv(info,& else
& type='csr',dupl=psb_dupl_add_) call sm%nd%cscnv(info,&
endif & type='csr',dupl=psb_dupl_add_)
endif
end if
end if end if
if (allocated(sm%sv)) & if (allocated(sm%sv)) &

1
mlprec/impl/smoother/mld_c_jac_smoother_descr.f90
Unescape Escape View File

@ -75,6 +75,7 @@ subroutine mld_c_jac_smoother_descr(sm,info,iout,coarse)
select type(smv=>sm%sv) select type(smv=>sm%sv)
class is (mld_c_diag_solver_type) class is (mld_c_diag_solver_type)
write(iout_,*) ' Point Jacobi ' write(iout_,*) ' Point Jacobi '
call smv%descr(info,iout_,coarse=coarse)
class is (mld_c_bwgs_solver_type) class is (mld_c_bwgs_solver_type)
write(iout_,*) ' Hybrid Backward Gauss-Seidel ' write(iout_,*) ' Hybrid Backward Gauss-Seidel '
class is (mld_c_gs_solver_type) class is (mld_c_gs_solver_type)

173
mlprec/impl/smoother/mld_d_jac_smoother_apply.f90
Unescape Escape View File

@ -114,73 +114,134 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
endif endif
else if (sweeps >= 0) then else if (sweeps >= 0) then
! if (associated(sm%pa)) then
! !
! Apply multiple sweeps of a block-Jacobi solver ! This means we are dealing with a pure Jacobi smoother/solver.
! to compute an approximate solution of a linear system. !
! call psb_geasb(tx,desc_data,info)
! call psb_geasb(ty,desc_data,info)
call psb_geasb(tx,desc_data,info) select case (init_)
call psb_geasb(ty,desc_data,info) case('Z')
! call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z')
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be case('Y')
! significant when sweeps=1 (a common case) call psb_geaxpby(done,x,dzero,tx,desc_data,info)
! call psb_geaxpby(done,y,dzero,ty,desc_data,info)
select case (init_) call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
case('Z') call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z') case('U')
if (.not.present(initu)) then
case('Y') call psb_errpush(psb_err_internal_error_,name,&
call psb_geaxpby(done,x,dzero,tx,desc_data,info) & a_err='missing initu to smoother_apply')
call psb_geaxpby(done,y,dzero,ty,desc_data,info) goto 9999
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) end if
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
case('U') call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
if (.not.present(initu)) then call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply') & a_err='wrong init to smoother_apply')
goto 9999 goto 9999
end select
do i=1, sweeps-1
!
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
! where is the diagonal and A the matrix.
!
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if end if
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,initu,dzero,ty,desc_data,info) else
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) !
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') !
! Apply multiple sweeps of a block-Jacobi solver
case default ! to compute an approximate solution of a linear system.
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
do i=1, sweeps-1
! !
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! !
call psb_geaxpby(done,x,dzero,tx,desc_data,info) call psb_geasb(tx,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) call psb_geasb(ty,desc_data,info)
if (info /= psb_success_) exit !
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
select case (init_)
case('Z')
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z')
if (info /= psb_success_) exit case('Y')
end do call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) then case default
info=psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,&
call psb_errpush(info,name,& & a_err='wrong init to smoother_apply')
& a_err='subsolve with Jacobi sweeps > 1') goto 9999
goto 9999 end select
end if
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end if
deallocate(tx,ty,stat=info) deallocate(tx,ty,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_

175
mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -115,80 +115,143 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
goto 9999 goto 9999
endif endif
else if (sweeps >= 0) then else if (sweeps >= 0) then
! if (associated(sm%pa)) then
!
! Apply multiple sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2))
! !
! Unroll the first iteration and fold it inside SELECT CASE ! This means we are dealing with a pure Jacobi smoother/solver.
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
! !
select case (init_) associate(tx => wv(1), ty => wv(2))
case('Z') select case (init_)
case('Z')
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y')
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('Y') case('U')
call psb_geaxpby(done,x,dzero,tx,desc_data,info) if (.not.present(initu)) then
call psb_geaxpby(done,y,dzero,ty,desc_data,info) call psb_errpush(psb_err_internal_error_,name,&
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) & a_err='missing initu to smoother_apply')
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') goto 9999
end if
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('U') case default
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply') & a_err='wrong init to smoother_apply')
goto 9999 goto 9999
end select
do i=1, sweeps-1
!
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
! where is the diagonal and A the matrix.
!
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if end if
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) end associate
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
else
case default !
call psb_errpush(psb_err_internal_error_,name,& !
& a_err='wrong init to smoother_apply') ! Apply multiple sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999 goto 9999
end select end if
associate(tx => wv(1), ty => wv(2))
do i=1, sweeps-1
! !
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the ! Unroll the first iteration and fold it inside SELECT CASE
! block diagonal part and the remaining part of the local matrix ! this will save one AXPBY and one SPMM when INIT=Z, and will be
! and Y(j) is the approximate solution at sweep j. ! significant when sweeps=1 (a common case)
! !
call psb_geaxpby(done,x,dzero,tx,desc_data,info) select case (init_)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) case('Z')
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
if (info /= psb_success_) exit case('Y')
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit case default
end do call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) then if (info /= psb_success_) exit
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate
end if
else else

32
mlprec/impl/smoother/mld_d_jac_smoother_bld.f90
Unescape Escape View File

@ -71,26 +71,33 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
nrow_a = a%get_nrows() nrow_a = a%get_nrows()
nztota = a%get_nzeros() nztota = a%get_nzeros()
select type (smsv => sm%sv) select type (smsv => sm%sv)
type is (mld_d_diag_solver_type) class is (mld_d_diag_solver_type)
call a%clip_diag(sm%nd,info) call sm%nd%free()
sm%pa => a
sm%nnz_nd_tot = nztota
class default class default
call a%csclip(sm%nd,info,& call a%csclip(sm%nd,info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.) & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
if (info == psb_success_) then
if (present(amold)) then
call sm%nd%cscnv(info,&
& mold=amold,dupl=psb_dupl_add_)
else
call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
endif
end if
sm%nnz_nd_tot = sm%nd%get_nzeros()
end select end select
if (info == psb_success_) then
if (present(amold)) then
call sm%nd%cscnv(info,&
& mold=amold,dupl=psb_dupl_add_)
else
call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
endif
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,& call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='clip & psb_spcnv csr 4') & a_err='clip & psb_spcnv csr 4')
goto 9999 goto 9999
end if end if
call psb_sum(ictxt,sm%nnz_nd_tot)
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -98,9 +105,6 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
& a_err='solver build') & a_err='solver build')
goto 9999 goto 9999
end if end if
nzeros = sm%nd%get_nzeros()
call psb_sum(ictxt,nzeros)
sm%nnz_nd_tot = nzeros
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end' & write(debug_unit,*) me,' ',trim(name),' end'

18
mlprec/impl/smoother/mld_d_jac_smoother_cnv.f90
Unescape Escape View File

@ -58,14 +58,16 @@ subroutine mld_d_jac_smoother_cnv(sm,info,amold,vmold,imold)
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
if (info == psb_success_) then if (info == psb_success_) then
if (present(amold)) then if (.not.associated(sm%pa)) then
call sm%nd%cscnv(info,& if (present(amold)) then
& mold=amold,dupl=psb_dupl_add_) call sm%nd%cscnv(info,&
else & mold=amold,dupl=psb_dupl_add_)
call sm%nd%cscnv(info,& else
& type='csr',dupl=psb_dupl_add_) call sm%nd%cscnv(info,&
endif & type='csr',dupl=psb_dupl_add_)
endif
end if
end if end if
if (allocated(sm%sv)) & if (allocated(sm%sv)) &

1
mlprec/impl/smoother/mld_d_jac_smoother_descr.f90
Unescape Escape View File

@ -75,6 +75,7 @@ subroutine mld_d_jac_smoother_descr(sm,info,iout,coarse)
select type(smv=>sm%sv) select type(smv=>sm%sv)
class is (mld_d_diag_solver_type) class is (mld_d_diag_solver_type)
write(iout_,*) ' Point Jacobi ' write(iout_,*) ' Point Jacobi '
call smv%descr(info,iout_,coarse=coarse)
class is (mld_d_bwgs_solver_type) class is (mld_d_bwgs_solver_type)
write(iout_,*) ' Hybrid Backward Gauss-Seidel ' write(iout_,*) ' Hybrid Backward Gauss-Seidel '
class is (mld_d_gs_solver_type) class is (mld_d_gs_solver_type)

173
mlprec/impl/smoother/mld_s_jac_smoother_apply.f90
Unescape Escape View File

@ -114,73 +114,134 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
endif endif
else if (sweeps >= 0) then else if (sweeps >= 0) then
! if (associated(sm%pa)) then
! !
! Apply multiple sweeps of a block-Jacobi solver ! This means we are dealing with a pure Jacobi smoother/solver.
! to compute an approximate solution of a linear system. !
! call psb_geasb(tx,desc_data,info)
! call psb_geasb(ty,desc_data,info)
call psb_geasb(tx,desc_data,info) select case (init_)
call psb_geasb(ty,desc_data,info) case('Z')
! call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z')
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be case('Y')
! significant when sweeps=1 (a common case) call psb_geaxpby(sone,x,szero,tx,desc_data,info)
! call psb_geaxpby(sone,y,szero,ty,desc_data,info)
select case (init_) call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
case('Z') call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z') case('U')
if (.not.present(initu)) then
case('Y') call psb_errpush(psb_err_internal_error_,name,&
call psb_geaxpby(sone,x,szero,tx,desc_data,info) & a_err='missing initu to smoother_apply')
call psb_geaxpby(sone,y,szero,ty,desc_data,info) goto 9999
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) end if
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
case('U') call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
if (.not.present(initu)) then call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply') & a_err='wrong init to smoother_apply')
goto 9999 goto 9999
end select
do i=1, sweeps-1
!
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
! where is the diagonal and A the matrix.
!
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if end if
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,initu,szero,ty,desc_data,info) else
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) !
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') !
! Apply multiple sweeps of a block-Jacobi solver
case default ! to compute an approximate solution of a linear system.
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
do i=1, sweeps-1
! !
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! !
call psb_geaxpby(sone,x,szero,tx,desc_data,info) call psb_geasb(tx,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) call psb_geasb(ty,desc_data,info)
if (info /= psb_success_) exit !
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
select case (init_)
case('Z')
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z')
if (info /= psb_success_) exit case('Y')
end do call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) then case default
info=psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,&
call psb_errpush(info,name,& & a_err='wrong init to smoother_apply')
& a_err='subsolve with Jacobi sweeps > 1') goto 9999
goto 9999 end select
end if
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end if
deallocate(tx,ty,stat=info) deallocate(tx,ty,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_

175
mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -115,80 +115,143 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
goto 9999 goto 9999
endif endif
else if (sweeps >= 0) then else if (sweeps >= 0) then
! if (associated(sm%pa)) then
!
! Apply multiple sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2))
! !
! Unroll the first iteration and fold it inside SELECT CASE ! This means we are dealing with a pure Jacobi smoother/solver.
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
! !
select case (init_) associate(tx => wv(1), ty => wv(2))
case('Z') select case (init_)
case('Z')
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y')
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('Y') case('U')
call psb_geaxpby(sone,x,szero,tx,desc_data,info) if (.not.present(initu)) then
call psb_geaxpby(sone,y,szero,ty,desc_data,info) call psb_errpush(psb_err_internal_error_,name,&
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) & a_err='missing initu to smoother_apply')
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') goto 9999
end if
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('U') case default
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply') & a_err='wrong init to smoother_apply')
goto 9999 goto 9999
end select
do i=1, sweeps-1
!
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
! where is the diagonal and A the matrix.
!
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if end if
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) end associate
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
else
case default !
call psb_errpush(psb_err_internal_error_,name,& !
& a_err='wrong init to smoother_apply') ! Apply multiple sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999 goto 9999
end select end if
associate(tx => wv(1), ty => wv(2))
do i=1, sweeps-1
! !
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the ! Unroll the first iteration and fold it inside SELECT CASE
! block diagonal part and the remaining part of the local matrix ! this will save one AXPBY and one SPMM when INIT=Z, and will be
! and Y(j) is the approximate solution at sweep j. ! significant when sweeps=1 (a common case)
! !
call psb_geaxpby(sone,x,szero,tx,desc_data,info) select case (init_)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) case('Z')
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
if (info /= psb_success_) exit case('Y')
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit case default
end do call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) then if (info /= psb_success_) exit
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate
end if
else else

32
mlprec/impl/smoother/mld_s_jac_smoother_bld.f90
Unescape Escape View File

@ -71,26 +71,33 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
nrow_a = a%get_nrows() nrow_a = a%get_nrows()
nztota = a%get_nzeros() nztota = a%get_nzeros()
select type (smsv => sm%sv) select type (smsv => sm%sv)
type is (mld_s_diag_solver_type) class is (mld_s_diag_solver_type)
call a%clip_diag(sm%nd,info) call sm%nd%free()
sm%pa => a
sm%nnz_nd_tot = nztota
class default class default
call a%csclip(sm%nd,info,& call a%csclip(sm%nd,info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.) & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
if (info == psb_success_) then
if (present(amold)) then
call sm%nd%cscnv(info,&
& mold=amold,dupl=psb_dupl_add_)
else
call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
endif
end if
sm%nnz_nd_tot = sm%nd%get_nzeros()
end select end select
if (info == psb_success_) then
if (present(amold)) then
call sm%nd%cscnv(info,&
& mold=amold,dupl=psb_dupl_add_)
else
call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
endif
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,& call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='clip & psb_spcnv csr 4') & a_err='clip & psb_spcnv csr 4')
goto 9999 goto 9999
end if end if
call psb_sum(ictxt,sm%nnz_nd_tot)
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -98,9 +105,6 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
& a_err='solver build') & a_err='solver build')
goto 9999 goto 9999
end if end if
nzeros = sm%nd%get_nzeros()
call psb_sum(ictxt,nzeros)
sm%nnz_nd_tot = nzeros
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end' & write(debug_unit,*) me,' ',trim(name),' end'

18
mlprec/impl/smoother/mld_s_jac_smoother_cnv.f90
Unescape Escape View File

@ -58,14 +58,16 @@ subroutine mld_s_jac_smoother_cnv(sm,info,amold,vmold,imold)
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
if (info == psb_success_) then if (info == psb_success_) then
if (present(amold)) then if (.not.associated(sm%pa)) then
call sm%nd%cscnv(info,& if (present(amold)) then
& mold=amold,dupl=psb_dupl_add_) call sm%nd%cscnv(info,&
else & mold=amold,dupl=psb_dupl_add_)
call sm%nd%cscnv(info,& else
& type='csr',dupl=psb_dupl_add_) call sm%nd%cscnv(info,&
endif & type='csr',dupl=psb_dupl_add_)
endif
end if
end if end if
if (allocated(sm%sv)) & if (allocated(sm%sv)) &

1
mlprec/impl/smoother/mld_s_jac_smoother_descr.f90
Unescape Escape View File

@ -75,6 +75,7 @@ subroutine mld_s_jac_smoother_descr(sm,info,iout,coarse)
select type(smv=>sm%sv) select type(smv=>sm%sv)
class is (mld_s_diag_solver_type) class is (mld_s_diag_solver_type)
write(iout_,*) ' Point Jacobi ' write(iout_,*) ' Point Jacobi '
call smv%descr(info,iout_,coarse=coarse)
class is (mld_s_bwgs_solver_type) class is (mld_s_bwgs_solver_type)
write(iout_,*) ' Hybrid Backward Gauss-Seidel ' write(iout_,*) ' Hybrid Backward Gauss-Seidel '
class is (mld_s_gs_solver_type) class is (mld_s_gs_solver_type)

173
mlprec/impl/smoother/mld_z_jac_smoother_apply.f90
Unescape Escape View File

@ -114,73 +114,134 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
endif endif
else if (sweeps >= 0) then else if (sweeps >= 0) then
! if (associated(sm%pa)) then
! !
! Apply multiple sweeps of a block-Jacobi solver ! This means we are dealing with a pure Jacobi smoother/solver.
! to compute an approximate solution of a linear system. !
! call psb_geasb(tx,desc_data,info)
! call psb_geasb(ty,desc_data,info)
call psb_geasb(tx,desc_data,info) select case (init_)
call psb_geasb(ty,desc_data,info) case('Z')
! call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,info,init='Z')
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be case('Y')
! significant when sweeps=1 (a common case) call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
! call psb_geaxpby(zone,y,zzero,ty,desc_data,info)
select case (init_) call psb_spmm(-zone,sm%pa,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
case('Z') call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y')
call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,info,init='Z') case('U')
if (.not.present(initu)) then
case('Y') call psb_errpush(psb_err_internal_error_,name,&
call psb_geaxpby(zone,x,zzero,tx,desc_data,info) & a_err='missing initu to smoother_apply')
call psb_geaxpby(zone,y,zzero,ty,desc_data,info) goto 9999
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) end if
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
case('U') call psb_spmm(-zone,sm%pa,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
if (.not.present(initu)) then call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply') & a_err='wrong init to smoother_apply')
goto 9999 goto 9999
end select
do i=1, sweeps-1
!
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
! where is the diagonal and A the matrix.
!
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_spmm(-zone,sm%pa,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(zone,tx,zone,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if end if
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) else
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) !
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') !
! Apply multiple sweeps of a block-Jacobi solver
case default ! to compute an approximate solution of a linear system.
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
do i=1, sweeps-1
! !
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! !
call psb_geaxpby(zone,x,zzero,tx,desc_data,info) call psb_geasb(tx,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) call psb_geasb(ty,desc_data,info)
if (info /= psb_success_) exit !
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
select case (init_)
case('Z')
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,info,init='Z')
if (info /= psb_success_) exit case('Y')
end do call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,y,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y')
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) then case default
info=psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,&
call psb_errpush(info,name,& & a_err='wrong init to smoother_apply')
& a_err='subsolve with Jacobi sweeps > 1') goto 9999
goto 9999 end select
end if
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end if
deallocate(tx,ty,stat=info) deallocate(tx,ty,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_

175
mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -115,80 +115,143 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
goto 9999 goto 9999
endif endif
else if (sweeps >= 0) then else if (sweeps >= 0) then
! if (associated(sm%pa)) then
!
! Apply multiple sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2))
! !
! Unroll the first iteration and fold it inside SELECT CASE ! This means we are dealing with a pure Jacobi smoother/solver.
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
! !
select case (init_) associate(tx => wv(1), ty => wv(2))
case('Z') select case (init_)
case('Z')
call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y')
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,y,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%pa,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('Y') case('U')
call psb_geaxpby(zone,x,zzero,tx,desc_data,info) if (.not.present(initu)) then
call psb_geaxpby(zone,y,zzero,ty,desc_data,info) call psb_errpush(psb_err_internal_error_,name,&
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) & a_err='missing initu to smoother_apply')
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') goto 9999
end if
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%pa,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('U') case default
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply') & a_err='wrong init to smoother_apply')
goto 9999 goto 9999
end select
do i=1, sweeps-1
!
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
! where is the diagonal and A the matrix.
!
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_spmm(-zone,sm%pa,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(zone,tx,zone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if end if
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) end associate
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
else
case default !
call psb_errpush(psb_err_internal_error_,name,& !
& a_err='wrong init to smoother_apply') ! Apply multiple sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999 goto 9999
end select end if
associate(tx => wv(1), ty => wv(2))
do i=1, sweeps-1
! !
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the ! Unroll the first iteration and fold it inside SELECT CASE
! block diagonal part and the remaining part of the local matrix ! this will save one AXPBY and one SPMM when INIT=Z, and will be
! and Y(j) is the approximate solution at sweep j. ! significant when sweeps=1 (a common case)
! !
call psb_geaxpby(zone,x,zzero,tx,desc_data,info) select case (init_)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) case('Z')
call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
if (info /= psb_success_) exit case('Y')
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,y,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit case default
end do call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) then if (info /= psb_success_) exit
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info /= psb_success_) exit
end do
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate
end if
else else

32
mlprec/impl/smoother/mld_z_jac_smoother_bld.f90
Unescape Escape View File

@ -71,26 +71,33 @@ subroutine mld_z_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
nrow_a = a%get_nrows() nrow_a = a%get_nrows()
nztota = a%get_nzeros() nztota = a%get_nzeros()
select type (smsv => sm%sv) select type (smsv => sm%sv)
type is (mld_z_diag_solver_type) class is (mld_z_diag_solver_type)
call a%clip_diag(sm%nd,info) call sm%nd%free()
sm%pa => a
sm%nnz_nd_tot = nztota
class default class default
call a%csclip(sm%nd,info,& call a%csclip(sm%nd,info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.) & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
if (info == psb_success_) then
if (present(amold)) then
call sm%nd%cscnv(info,&
& mold=amold,dupl=psb_dupl_add_)
else
call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
endif
end if
sm%nnz_nd_tot = sm%nd%get_nzeros()
end select end select
if (info == psb_success_) then
if (present(amold)) then
call sm%nd%cscnv(info,&
& mold=amold,dupl=psb_dupl_add_)
else
call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
endif
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,& call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='clip & psb_spcnv csr 4') & a_err='clip & psb_spcnv csr 4')
goto 9999 goto 9999
end if end if
call psb_sum(ictxt,sm%nnz_nd_tot)
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold) call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -98,9 +105,6 @@ subroutine mld_z_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
& a_err='solver build') & a_err='solver build')
goto 9999 goto 9999
end if end if
nzeros = sm%nd%get_nzeros()
call psb_sum(ictxt,nzeros)
sm%nnz_nd_tot = nzeros
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end' & write(debug_unit,*) me,' ',trim(name),' end'

18
mlprec/impl/smoother/mld_z_jac_smoother_cnv.f90
Unescape Escape View File

@ -58,14 +58,16 @@ subroutine mld_z_jac_smoother_cnv(sm,info,amold,vmold,imold)
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
if (info == psb_success_) then if (info == psb_success_) then
if (present(amold)) then if (.not.associated(sm%pa)) then
call sm%nd%cscnv(info,& if (present(amold)) then
& mold=amold,dupl=psb_dupl_add_) call sm%nd%cscnv(info,&
else & mold=amold,dupl=psb_dupl_add_)
call sm%nd%cscnv(info,& else
& type='csr',dupl=psb_dupl_add_) call sm%nd%cscnv(info,&
endif & type='csr',dupl=psb_dupl_add_)
endif
end if
end if end if
if (allocated(sm%sv)) & if (allocated(sm%sv)) &

1
mlprec/impl/smoother/mld_z_jac_smoother_descr.f90
Unescape Escape View File

@ -75,6 +75,7 @@ subroutine mld_z_jac_smoother_descr(sm,info,iout,coarse)
select type(smv=>sm%sv) select type(smv=>sm%sv)
class is (mld_z_diag_solver_type) class is (mld_z_diag_solver_type)
write(iout_,*) ' Point Jacobi ' write(iout_,*) ' Point Jacobi '
call smv%descr(info,iout_,coarse=coarse)
class is (mld_z_bwgs_solver_type) class is (mld_z_bwgs_solver_type)
write(iout_,*) ' Hybrid Backward Gauss-Seidel ' write(iout_,*) ' Hybrid Backward Gauss-Seidel '
class is (mld_z_gs_solver_type) class is (mld_z_gs_solver_type)

6
mlprec/mld_c_jac_smoother.f90
Unescape Escape View File

@ -58,8 +58,9 @@ module mld_c_jac_smoother
! parent type. ! parent type.
! class(mld_c_base_solver_type), allocatable :: sv ! class(mld_c_base_solver_type), allocatable :: sv
! !
type(psb_cspmat_type), pointer :: pa => null()
type(psb_cspmat_type) :: nd type(psb_cspmat_type) :: nd
integer(psb_ipk_) :: nnz_nd_tot integer(psb_ipk_) :: nnz_nd_tot
contains contains
procedure, pass(sm) :: dump => mld_c_jac_smoother_dmp procedure, pass(sm) :: dump => mld_c_jac_smoother_dmp
procedure, pass(sm) :: build => mld_c_jac_smoother_bld procedure, pass(sm) :: build => mld_c_jac_smoother_bld
@ -217,7 +218,8 @@ contains
end if end if
end if end if
call sm%nd%free() call sm%nd%free()
sm%pa => null()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

6
mlprec/mld_d_jac_smoother.f90
Unescape Escape View File

@ -58,8 +58,9 @@ module mld_d_jac_smoother
! parent type. ! parent type.
! class(mld_d_base_solver_type), allocatable :: sv ! class(mld_d_base_solver_type), allocatable :: sv
! !
type(psb_dspmat_type), pointer :: pa => null()
type(psb_dspmat_type) :: nd type(psb_dspmat_type) :: nd
integer(psb_ipk_) :: nnz_nd_tot integer(psb_ipk_) :: nnz_nd_tot
contains contains
procedure, pass(sm) :: dump => mld_d_jac_smoother_dmp procedure, pass(sm) :: dump => mld_d_jac_smoother_dmp
procedure, pass(sm) :: build => mld_d_jac_smoother_bld procedure, pass(sm) :: build => mld_d_jac_smoother_bld
@ -217,7 +218,8 @@ contains
end if end if
end if end if
call sm%nd%free() call sm%nd%free()
sm%pa => null()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

6
mlprec/mld_s_jac_smoother.f90
Unescape Escape View File

@ -58,8 +58,9 @@ module mld_s_jac_smoother
! parent type. ! parent type.
! class(mld_s_base_solver_type), allocatable :: sv ! class(mld_s_base_solver_type), allocatable :: sv
! !
type(psb_sspmat_type), pointer :: pa => null()
type(psb_sspmat_type) :: nd type(psb_sspmat_type) :: nd
integer(psb_ipk_) :: nnz_nd_tot integer(psb_ipk_) :: nnz_nd_tot
contains contains
procedure, pass(sm) :: dump => mld_s_jac_smoother_dmp procedure, pass(sm) :: dump => mld_s_jac_smoother_dmp
procedure, pass(sm) :: build => mld_s_jac_smoother_bld procedure, pass(sm) :: build => mld_s_jac_smoother_bld
@ -217,7 +218,8 @@ contains
end if end if
end if end if
call sm%nd%free() call sm%nd%free()
sm%pa => null()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

6
mlprec/mld_z_jac_smoother.f90
Unescape Escape View File

@ -58,8 +58,9 @@ module mld_z_jac_smoother
! parent type. ! parent type.
! class(mld_z_base_solver_type), allocatable :: sv ! class(mld_z_base_solver_type), allocatable :: sv
! !
type(psb_zspmat_type), pointer :: pa => null()
type(psb_zspmat_type) :: nd type(psb_zspmat_type) :: nd
integer(psb_ipk_) :: nnz_nd_tot integer(psb_ipk_) :: nnz_nd_tot
contains contains
procedure, pass(sm) :: dump => mld_z_jac_smoother_dmp procedure, pass(sm) :: dump => mld_z_jac_smoother_dmp
procedure, pass(sm) :: build => mld_z_jac_smoother_bld procedure, pass(sm) :: build => mld_z_jac_smoother_bld
@ -217,7 +218,8 @@ contains
end if end if
end if end if
call sm%nd%free() call sm%nd%free()
sm%pa => null()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save