|
|
|
@ -115,80 +115,143 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
|
|
|
|
goto 9999
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
else if (sweeps >= 0) 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))
|
|
|
|
|
|
|
|
|
|
else if (sweeps >= 0) then
|
|
|
|
|
if (associated(sm%pa)) then
|
|
|
|
|
!
|
|
|
|
|
! 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)
|
|
|
|
|
! This means we are dealing with a pure Jacobi smoother/solver.
|
|
|
|
|
!
|
|
|
|
|
select case (init_)
|
|
|
|
|
case('Z')
|
|
|
|
|
associate(tx => wv(1), ty => wv(2))
|
|
|
|
|
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')
|
|
|
|
|
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')
|
|
|
|
|
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%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')
|
|
|
|
|
if (.not.present(initu)) then
|
|
|
|
|
case default
|
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
|
& a_err='missing initu to smoother_apply')
|
|
|
|
|
& a_err='wrong init to smoother_apply')
|
|
|
|
|
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
|
|
|
|
|
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')
|
|
|
|
|
|
|
|
|
|
case default
|
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
|
& a_err='wrong init to smoother_apply')
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end associate
|
|
|
|
|
|
|
|
|
|
else
|
|
|
|
|
!
|
|
|
|
|
!
|
|
|
|
|
! 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 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
|
|
|
|
|
! block diagonal part and the remaining part of the local matrix
|
|
|
|
|
! and Y(j) is the approximate solution at sweep j.
|
|
|
|
|
! 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)
|
|
|
|
|
!
|
|
|
|
|
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_)
|
|
|
|
|
select case (init_)
|
|
|
|
|
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
|
|
|
|
|
end do
|
|
|
|
|
case default
|
|
|
|
|
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
|
|
|
|
|
info=psb_err_internal_error_
|
|
|
|
|
call psb_errpush(info,name,&
|
|
|
|
|
& a_err='subsolve with Jacobi sweeps > 1')
|
|
|
|
|
goto 9999
|
|
|
|
|
end if
|
|
|
|
|
if (info /= psb_success_) exit
|
|
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|