|
|
|
@ -55,16 +55,17 @@ module mld_d_as_smoother
|
|
|
|
|
type(psb_desc_type) :: desc_data
|
|
|
|
|
integer :: novr, restr, prol, nd_nnz_tot
|
|
|
|
|
contains
|
|
|
|
|
procedure, pass(sm) :: check => d_as_smoother_check
|
|
|
|
|
procedure, pass(sm) :: dump => d_as_smoother_dmp
|
|
|
|
|
procedure, pass(sm) :: build => d_as_smoother_bld
|
|
|
|
|
procedure, pass(sm) :: apply => d_as_smoother_apply
|
|
|
|
|
procedure, pass(sm) :: free => d_as_smoother_free
|
|
|
|
|
procedure, pass(sm) :: seti => d_as_smoother_seti
|
|
|
|
|
procedure, pass(sm) :: setc => d_as_smoother_setc
|
|
|
|
|
procedure, pass(sm) :: setr => d_as_smoother_setr
|
|
|
|
|
procedure, pass(sm) :: descr => d_as_smoother_descr
|
|
|
|
|
procedure, pass(sm) :: sizeof => d_as_smoother_sizeof
|
|
|
|
|
procedure, pass(sm) :: check => d_as_smoother_check
|
|
|
|
|
procedure, pass(sm) :: dump => d_as_smoother_dmp
|
|
|
|
|
procedure, pass(sm) :: build => d_as_smoother_bld
|
|
|
|
|
procedure, pass(sm) :: apply_v => d_as_smoother_apply_vect
|
|
|
|
|
procedure, pass(sm) :: apply_a => d_as_smoother_apply
|
|
|
|
|
procedure, pass(sm) :: free => d_as_smoother_free
|
|
|
|
|
procedure, pass(sm) :: seti => d_as_smoother_seti
|
|
|
|
|
procedure, pass(sm) :: setc => d_as_smoother_setc
|
|
|
|
|
procedure, pass(sm) :: setr => d_as_smoother_setr
|
|
|
|
|
procedure, pass(sm) :: descr => d_as_smoother_descr
|
|
|
|
|
procedure, pass(sm) :: sizeof => d_as_smoother_sizeof
|
|
|
|
|
procedure, pass(sm) :: default => d_as_smoother_default
|
|
|
|
|
end type mld_d_as_smoother_type
|
|
|
|
|
|
|
|
|
@ -74,7 +75,7 @@ module mld_d_as_smoother
|
|
|
|
|
& d_as_smoother_setc, d_as_smoother_setr,&
|
|
|
|
|
& d_as_smoother_descr, d_as_smoother_sizeof, &
|
|
|
|
|
& d_as_smoother_check, d_as_smoother_default,&
|
|
|
|
|
& d_as_smoother_dmp
|
|
|
|
|
& d_as_smoother_dmp, d_as_smoother_apply_vect
|
|
|
|
|
|
|
|
|
|
character(len=6), parameter, private :: &
|
|
|
|
|
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
|
|
|
|
@ -151,6 +152,442 @@ contains
|
|
|
|
|
return
|
|
|
|
|
end subroutine d_as_smoother_check
|
|
|
|
|
|
|
|
|
|
subroutine d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
|
|
|
|
|
use psb_base_mod
|
|
|
|
|
type(psb_desc_type), intent(in) :: desc_data
|
|
|
|
|
class(mld_d_as_smoother_type), intent(inout) :: sm
|
|
|
|
|
type(psb_d_vect_type),intent(inout) :: x
|
|
|
|
|
type(psb_d_vect_type),intent(inout) :: y
|
|
|
|
|
real(psb_dpk_),intent(in) :: alpha,beta
|
|
|
|
|
character(len=1),intent(in) :: trans
|
|
|
|
|
integer, intent(in) :: sweeps
|
|
|
|
|
real(psb_dpk_),target, intent(inout) :: work(:)
|
|
|
|
|
integer, intent(out) :: info
|
|
|
|
|
|
|
|
|
|
integer :: n_row,n_col, nrow_d, i
|
|
|
|
|
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
|
|
|
|
|
integer :: ictxt,np,me, err_act,isz,int_err(5)
|
|
|
|
|
character :: trans_
|
|
|
|
|
character(len=20) :: name='d_as_smoother_apply', ch_err
|
|
|
|
|
|
|
|
|
|
call psb_erractionsave(err_act)
|
|
|
|
|
|
|
|
|
|
info = psb_success_
|
|
|
|
|
ictxt = desc_data%get_context()
|
|
|
|
|
call psb_info(ictxt,me,np)
|
|
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
if (.not.allocated(sm%sv)) then
|
|
|
|
|
info = 1121
|
|
|
|
|
call psb_errpush(info,name)
|
|
|
|
|
goto 9999
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
n_row = sm%desc_data%get_local_rows()
|
|
|
|
|
n_col = sm%desc_data%get_local_cols()
|
|
|
|
|
nrow_d = desc_data%get_local_rows()
|
|
|
|
|
isz=max(n_row,N_COL)
|
|
|
|
|
if ((6*isz) <= size(work)) then
|
|
|
|
|
ww => work(1:isz)
|
|
|
|
|
tx => work(isz+1:2*isz)
|
|
|
|
|
ty => work(2*isz+1:3*isz)
|
|
|
|
|
aux => work(3*isz+1:)
|
|
|
|
|
else if ((4*isz) <= size(work)) then
|
|
|
|
|
aux => work(1:)
|
|
|
|
|
allocate(ww(isz),tx(isz),ty(isz),stat=info)
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
|
call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),&
|
|
|
|
|
& a_err='real(psb_dpk_)')
|
|
|
|
|
goto 9999
|
|
|
|
|
end if
|
|
|
|
|
else if ((3*isz) <= size(work)) then
|
|
|
|
|
ww => work(1:isz)
|
|
|
|
|
tx => work(isz+1:2*isz)
|
|
|
|
|
ty => work(2*isz+1:3*isz)
|
|
|
|
|
allocate(aux(4*isz),stat=info)
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
|
call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),&
|
|
|
|
|
& a_err='real(psb_dpk_)')
|
|
|
|
|
goto 9999
|
|
|
|
|
end if
|
|
|
|
|
else
|
|
|
|
|
allocate(ww(isz),tx(isz),ty(isz),&
|
|
|
|
|
&aux(4*isz),stat=info)
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
|
call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),&
|
|
|
|
|
& a_err='real(psb_dpk_)')
|
|
|
|
|
goto 9999
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if ((sm%novr == 0).and.(sweeps == 1)) then
|
|
|
|
|
!
|
|
|
|
|
! Shortcut: in this case it's just the same
|
|
|
|
|
! as Block Jacobi.
|
|
|
|
|
!
|
|
|
|
|
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
|
|
|
|
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
|
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
|
|
|
|
goto 9999
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
|
|
!!$
|
|
|
|
|
!!$ tx(1:nrow_d) = x(1:nrow_d)
|
|
|
|
|
!!$ tx(nrow_d+1:isz) = dzero
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ if (sweeps == 1) then
|
|
|
|
|
!!$
|
|
|
|
|
!!$ select case(trans_)
|
|
|
|
|
!!$ case('N')
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Get the overlap entries of tx (tx == x)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ if (sm%restr == psb_halo_) then
|
|
|
|
|
!!$ call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_halo'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$ else if (sm%restr /= psb_none_) then
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case('T','C')
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! With transpose, we have to do it here
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$
|
|
|
|
|
!!$ select case (sm%prol)
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_none_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Do nothing
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_sum_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! The transpose of sum is halo
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_halo'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_avg_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Tricky one: first we have to scale the overlap entries,
|
|
|
|
|
!!$ ! which we can do by assignind mode=0, i.e. no communication
|
|
|
|
|
!!$ ! (hence only scaling), then we do the halo
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ call psb_ovrl(tx,sm%desc_data,info,&
|
|
|
|
|
!!$ & update=psb_avg_,work=aux,mode=0)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_ovrl'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$ call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_halo'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case default
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end select
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case default
|
|
|
|
|
!!$ info=psb_err_iarg_invalid_i_
|
|
|
|
|
!!$ int_err(1)=6
|
|
|
|
|
!!$ ch_err(2:2)=trans
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end select
|
|
|
|
|
!!$
|
|
|
|
|
!!$ call sm%sv%apply(done,tx,dzero,ty,sm%desc_data,trans_,aux,info)
|
|
|
|
|
!!$
|
|
|
|
|
!!$ if (info /= psb_success_) then
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
|
!!$ & a_err='Error in sub_aply Jacobi Sweeps = 1')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ endif
|
|
|
|
|
!!$
|
|
|
|
|
!!$ select case(trans_)
|
|
|
|
|
!!$ case('N')
|
|
|
|
|
!!$
|
|
|
|
|
!!$ select case (sm%prol)
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_none_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Would work anyway, but since it is supposed to do nothing ...
|
|
|
|
|
!!$ ! call psb_ovrl(ty,sm%desc_data,info,&
|
|
|
|
|
!!$ ! & update=sm%prol,work=aux)
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_sum_,psb_avg_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Update the overlap of ty
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ call psb_ovrl(ty,sm%desc_data,info,&
|
|
|
|
|
!!$ & update=sm%prol,work=aux)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_ovrl'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case default
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end select
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case('T','C')
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! With transpose, we have to do it here
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ if (sm%restr == psb_halo_) then
|
|
|
|
|
!!$ call psb_ovrl(ty,sm%desc_data,info,&
|
|
|
|
|
!!$ & update=psb_sum_,work=aux)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_ovrl'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$ else if (sm%restr /= psb_none_) then
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case default
|
|
|
|
|
!!$ info=psb_err_iarg_invalid_i_
|
|
|
|
|
!!$ int_err(1)=6
|
|
|
|
|
!!$ ch_err(2:2)=trans
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end select
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ else if (sweeps > 1) then
|
|
|
|
|
!!$
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver
|
|
|
|
|
!!$ ! to compute an approximate solution of a linear system.
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ty = dzero
|
|
|
|
|
!!$ do i=1, sweeps
|
|
|
|
|
!!$ select case(trans_)
|
|
|
|
|
!!$ case('N')
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Get the overlap entries of tx (tx == x)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ if (sm%restr == psb_halo_) then
|
|
|
|
|
!!$ call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_halo'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$ else if (sm%restr /= psb_none_) then
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case('T','C')
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! With transpose, we have to do it here
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$
|
|
|
|
|
!!$ select case (sm%prol)
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_none_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Do nothing
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_sum_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! The transpose of sum is halo
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_halo'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_avg_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Tricky one: first we have to scale the overlap entries,
|
|
|
|
|
!!$ ! which we can do by assignind mode=0, i.e. no communication
|
|
|
|
|
!!$ ! (hence only scaling), then we do the halo
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ call psb_ovrl(tx,sm%desc_data,info,&
|
|
|
|
|
!!$ & update=psb_avg_,work=aux,mode=0)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_ovrl'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$ call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_halo'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case default
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end select
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case default
|
|
|
|
|
!!$ info=psb_err_iarg_invalid_i_
|
|
|
|
|
!!$ int_err(1)=6
|
|
|
|
|
!!$ ch_err(2:2)=trans
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end select
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! 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.
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ww(1:n_row) = tx(1:n_row)
|
|
|
|
|
!!$ call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,work=aux,trans=trans_)
|
|
|
|
|
!!$
|
|
|
|
|
!!$ if (info /= psb_success_) exit
|
|
|
|
|
!!$
|
|
|
|
|
!!$ call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info)
|
|
|
|
|
!!$
|
|
|
|
|
!!$ if (info /= psb_success_) exit
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ select case(trans_)
|
|
|
|
|
!!$ case('N')
|
|
|
|
|
!!$
|
|
|
|
|
!!$ select case (sm%prol)
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_none_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Would work anyway, but since it is supposed to do nothing ...
|
|
|
|
|
!!$ ! call psb_ovrl(ty,sm%desc_data,info,&
|
|
|
|
|
!!$ ! & update=sm%prol,work=aux)
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case(psb_sum_,psb_avg_)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Update the overlap of ty
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ call psb_ovrl(ty,sm%desc_data,info,&
|
|
|
|
|
!!$ & update=sm%prol,work=aux)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_ovrl'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case default
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end select
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case('T','C')
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! With transpose, we have to do it here
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ if (sm%restr == psb_halo_) then
|
|
|
|
|
!!$ call psb_ovrl(ty,sm%desc_data,info,&
|
|
|
|
|
!!$ & update=psb_sum_,work=aux)
|
|
|
|
|
!!$ if(info /= psb_success_) then
|
|
|
|
|
!!$ info=psb_err_from_subroutine_
|
|
|
|
|
!!$ ch_err='psb_ovrl'
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$ else if (sm%restr /= psb_none_) then
|
|
|
|
|
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ case default
|
|
|
|
|
!!$ info=psb_err_iarg_invalid_i_
|
|
|
|
|
!!$ int_err(1)=6
|
|
|
|
|
!!$ ch_err(2:2)=trans
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$ end select
|
|
|
|
|
!!$ end do
|
|
|
|
|
!!$
|
|
|
|
|
!!$ 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
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ else
|
|
|
|
|
!!$
|
|
|
|
|
!!$ info = psb_err_iarg_neg_
|
|
|
|
|
!!$ call psb_errpush(info,name,&
|
|
|
|
|
!!$ & i_err=(/2,sweeps,0,0,0/))
|
|
|
|
|
!!$ goto 9999
|
|
|
|
|
!!$
|
|
|
|
|
!!$
|
|
|
|
|
!!$ end if
|
|
|
|
|
!!$
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
|
|
|
|
!!$ !
|
|
|
|
|
!!$ call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
|
|
|
|
!!$
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if ((6*isz) <= size(work)) then
|
|
|
|
|
else if ((4*isz) <= size(work)) then
|
|
|
|
|
deallocate(ww,tx,ty)
|
|
|
|
|
else if ((3*isz) <= size(work)) then
|
|
|
|
|
deallocate(aux)
|
|
|
|
|
else
|
|
|
|
|
deallocate(ww,aux,tx,ty)
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
call psb_erractionrestore(err_act)
|
|
|
|
|
return
|
|
|
|
|
|
|
|
|
|
9999 continue
|
|
|
|
|
call psb_erractionrestore(err_act)
|
|
|
|
|
if (err_act == psb_act_abort_) then
|
|
|
|
|
call psb_error()
|
|
|
|
|
return
|
|
|
|
|
end if
|
|
|
|
|
return
|
|
|
|
|
|
|
|
|
|
end subroutine d_as_smoother_apply_vect
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
subroutine d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
|
|
|
|
|
use psb_base_mod
|
|
|
|
|
type(psb_desc_type), intent(in) :: desc_data
|
|
|
|
@ -178,7 +615,8 @@ contains
|
|
|
|
|
trans_ = psb_toupper(trans)
|
|
|
|
|
select case(trans_)
|
|
|
|
|
case('N')
|
|
|
|
|
case('T','C')
|
|
|
|
|
case('T')
|
|
|
|
|
case('C')
|
|
|
|
|
case default
|
|
|
|
|
call psb_errpush(psb_err_iarg_invalid_i_,name)
|
|
|
|
|
goto 9999
|
|
|
|
@ -585,19 +1023,21 @@ contains
|
|
|
|
|
|
|
|
|
|
end subroutine d_as_smoother_apply
|
|
|
|
|
|
|
|
|
|
subroutine d_as_smoother_bld(a,desc_a,sm,upd,info,mold)
|
|
|
|
|
subroutine d_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
|
|
|
|
|
|
|
|
|
|
use psb_base_mod
|
|
|
|
|
|
|
|
|
|
Implicit None
|
|
|
|
|
|
|
|
|
|
! Arguments
|
|
|
|
|
type(psb_dspmat_type), intent(in), target :: a
|
|
|
|
|
Type(psb_desc_type), Intent(in) :: desc_a
|
|
|
|
|
class(mld_d_as_smoother_type), intent(inout) :: sm
|
|
|
|
|
character, intent(in) :: upd
|
|
|
|
|
integer, intent(out) :: info
|
|
|
|
|
class(psb_d_base_sparse_mat), intent(in), optional :: mold
|
|
|
|
|
type(psb_dspmat_type), intent(in), target :: a
|
|
|
|
|
Type(psb_desc_type), Intent(in) :: desc_a
|
|
|
|
|
class(mld_d_as_smoother_type), intent(inout) :: sm
|
|
|
|
|
character, intent(in) :: upd
|
|
|
|
|
integer, intent(out) :: info
|
|
|
|
|
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
|
|
|
|
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
|
|
|
|
|
|
|
|
|
! Local variables
|
|
|
|
|
type(psb_dspmat_type) :: blck, atmp
|
|
|
|
|
integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros
|
|
|
|
@ -688,7 +1128,8 @@ contains
|
|
|
|
|
|
|
|
|
|
End if
|
|
|
|
|
if (info == psb_success_) &
|
|
|
|
|
& call sm%sv%build(a,sm%desc_data,upd,info,blck,mold=mold)
|
|
|
|
|
& call sm%sv%build(a,sm%desc_data,upd,info,&
|
|
|
|
|
& blck,amold=amold,vmold=vmold)
|
|
|
|
|
|
|
|
|
|
nrow_a = a%get_nrows()
|
|
|
|
|
n_row = sm%desc_data%get_local_rows()
|
|
|
|
@ -699,9 +1140,16 @@ contains
|
|
|
|
|
if (info == psb_success_) call blck%csclip(atmp,info,&
|
|
|
|
|
& jmin=nrow_a+1,rscale=.false.,cscale=.false.)
|
|
|
|
|
if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp)
|
|
|
|
|
if (info == psb_success_) call sm%nd%cscnv(info,&
|
|
|
|
|
& type='csr',dupl=psb_dupl_add_)
|
|
|
|
|
|
|
|
|
|
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_)
|
|
|
|
|
end if
|
|
|
|
|
end if
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
|
call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4')
|
|
|
|
|
goto 9999
|
|
|
|
|