fdurastante/amg4psblas
1
0
Fork 0
mirror of https://github.com/sfilippone/amg4psblas.git synced 2026-10-20 21:02:35 +00:00
Code Issues Packages Projects Releases Wiki Activity

mld2p4-2:

Browse Source 
mlprec/impl/smoother/mld_d_jac_smoother_bld.f90
    mlprec/impl/smoother/mld_c_jac_smoother_apply.f90
    mlprec/impl/smoother/mld_s_jac_smoother_apply.f90
    mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90
    mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90
    mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90
    mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90
    mlprec/impl/smoother/mld_z_jac_smoother_apply.f90
    mlprec/impl/smoother/mld_z_jac_smoother_bld.f90
    mlprec/impl/smoother/mld_c_jac_smoother_bld.f90
    mlprec/impl/smoother/mld_s_jac_smoother_bld.f90
    mlprec/impl/smoother/mld_d_jac_smoother_apply.f90

Finish fix smoothers for long integers.
This commit is contained in:
Salvatore Filippone
2012-12-07 12:57:50 +00:00
parent db061fe5e1
commit bb63339295
12 changed files with 172 additions and 132 deletions
Download Patch File Download Diff File Expand all files Collapse all files
mlprec/impl/smoother/mld_c_jac_smoother_apply.f90
+18 -12
View File
@@ -46,14 +46,14 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
complex(psb_spk_),intent(inout) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer, intent(in) :: sweeps
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer(psb_ipk_), intent(out) :: info
integer :: n_row,n_col
integer(psb_ipk_) :: n_row,n_col
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='c_jac_smoother_apply'
@@ -87,7 +87,8 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
@@ -96,7 +97,8 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
@@ -123,7 +125,8 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(tx(n_col),ty(n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/2*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
@@ -137,7 +140,8 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
! and Y(j) is the approximate solution at sweep j.
!
ty(1:n_row) = x(1:n_row)
call psb_spmm(-cone,sm%nd,tx,cone,ty,desc_data,info,work=aux,trans=trans_)
call psb_spmm(-cone,sm%nd,tx,cone,ty,desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
@@ -150,14 +154,16 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
deallocate(tx,ty,stat=info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
@@ -165,7 +171,7 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
& i_err=(/itwo,sweeps,izero,izero,izero/))
goto 9999
endif
mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90
+19 -14
View File
@@ -36,25 +36,26 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info)
use psb_base_mod
use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
type(psb_desc_type), intent(in) :: desc_data
class(mld_c_jac_smoother_type), intent(inout) :: sm
type(psb_c_vect_type),intent(inout) :: x
type(psb_c_vect_type),intent(inout) :: y
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer, intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer :: n_row,n_col
integer(psb_ipk_) :: n_row,n_col
type(psb_c_vect_type) :: tx, ty
complex(psb_spk_), pointer :: ww(:), aux(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='c_jac_smoother_apply'
@@ -89,7 +90,8 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
@@ -98,7 +100,8 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
@@ -146,7 +149,8 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
@@ -154,7 +158,8 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
if (info == psb_success_) call ty%free(info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
@@ -162,7 +167,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
& i_err=(/itwo,sweeps,izero,izero,izero/))
goto 9999
endif
mlprec/impl/smoother/mld_c_jac_smoother_bld.f90
+6 -7
View File
@@ -37,7 +37,6 @@
!!$
!!$
subroutine mld_c_jac_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
use psb_base_mod
use mld_c_diag_solver
@@ -46,17 +45,17 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
! Arguments
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_c_jac_smoother_type), intent(inout) :: sm
character, intent(in) :: upd
integer, intent(out) :: info
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
! Local variables
integer :: n_row,n_col, nrow_a, nztota, nzeros
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='c_jac_smoother_bld', ch_err
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='c_jac_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
mlprec/impl/smoother/mld_d_jac_smoother_apply.f90
+18 -12
View File
@@ -46,14 +46,14 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
real(psb_dpk_),intent(inout) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer, intent(in) :: sweeps
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer(psb_ipk_), intent(out) :: info
integer :: n_row,n_col
integer(psb_ipk_) :: n_row,n_col
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_jac_smoother_apply'
@@ -87,7 +87,8 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
@@ -96,7 +97,8 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
@@ -123,7 +125,8 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(tx(n_col),ty(n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/2*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
@@ -137,7 +140,8 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
! and Y(j) is the approximate solution at sweep j.
!
ty(1:n_row) = x(1:n_row)
call psb_spmm(-done,sm%nd,tx,done,ty,desc_data,info,work=aux,trans=trans_)
call psb_spmm(-done,sm%nd,tx,done,ty,desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
@@ -150,14 +154,16 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
deallocate(tx,ty,stat=info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
@@ -165,7 +171,7 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
& i_err=(/itwo,sweeps,izero,izero,izero/))
goto 9999
endif
mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90
+19 -14
View File
@@ -36,25 +36,26 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info)
use psb_base_mod
use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
type(psb_desc_type), intent(in) :: desc_data
class(mld_d_jac_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
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer :: n_row,n_col
integer(psb_ipk_) :: n_row,n_col
type(psb_d_vect_type) :: tx, ty
real(psb_dpk_), pointer :: ww(:), aux(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_jac_smoother_apply'
@@ -89,7 +90,8 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
@@ -98,7 +100,8 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
@@ -146,7 +149,8 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
@@ -154,7 +158,8 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
if (info == psb_success_) call ty%free(info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
@@ -162,7 +167,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
& i_err=(/itwo,sweeps,izero,izero,izero/))
goto 9999
endif
mlprec/impl/smoother/mld_d_jac_smoother_bld.f90
+6 -7
View File
@@ -37,7 +37,6 @@
!!$
!!$
subroutine mld_d_jac_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
use psb_base_mod
use mld_d_diag_solver
@@ -46,17 +45,17 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
! Arguments
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_d_jac_smoother_type), intent(inout) :: sm
character, intent(in) :: upd
integer, intent(out) :: info
character, intent(in) :: upd
integer(psb_ipk_), 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
integer :: n_row,n_col, nrow_a, nztota, nzeros
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_jac_smoother_bld', ch_err
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_jac_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
mlprec/impl/smoother/mld_s_jac_smoother_apply.f90
+18 -12
View File
@@ -46,14 +46,14 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
real(psb_spk_),intent(inout) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer, intent(in) :: sweeps
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer(psb_ipk_), intent(out) :: info
integer :: n_row,n_col
integer(psb_ipk_) :: n_row,n_col
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='s_jac_smoother_apply'
@@ -87,7 +87,8 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
@@ -96,7 +97,8 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
@@ -123,7 +125,8 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(tx(n_col),ty(n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/2*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
@@ -137,7 +140,8 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
! and Y(j) is the approximate solution at sweep j.
!
ty(1:n_row) = x(1:n_row)
call psb_spmm(-sone,sm%nd,tx,sone,ty,desc_data,info,work=aux,trans=trans_)
call psb_spmm(-sone,sm%nd,tx,sone,ty,desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
@@ -150,14 +154,16 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
deallocate(tx,ty,stat=info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
@@ -165,7 +171,7 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
& i_err=(/itwo,sweeps,izero,izero,izero/))
goto 9999
endif
mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90
+19 -14
View File
@@ -36,25 +36,26 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info)
use psb_base_mod
use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_jac_smoother_type), intent(inout) :: sm
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer, intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer :: n_row,n_col
integer(psb_ipk_) :: n_row,n_col
type(psb_s_vect_type) :: tx, ty
real(psb_spk_), pointer :: ww(:), aux(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='s_jac_smoother_apply'
@@ -89,7 +90,8 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
@@ -98,7 +100,8 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
@@ -146,7 +149,8 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
@@ -154,7 +158,8 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
if (info == psb_success_) call ty%free(info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
@@ -162,7 +167,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
& i_err=(/itwo,sweeps,izero,izero,izero/))
goto 9999
endif
mlprec/impl/smoother/mld_s_jac_smoother_bld.f90
+6 -7
View File
@@ -37,7 +37,6 @@
!!$
!!$
subroutine mld_s_jac_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
use psb_base_mod
use mld_s_diag_solver
@@ -46,17 +45,17 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_jac_smoother_type), intent(inout) :: sm
character, intent(in) :: upd
integer, intent(out) :: info
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
! Local variables
integer :: n_row,n_col, nrow_a, nztota, nzeros
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='s_jac_smoother_bld', ch_err
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='s_jac_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
mlprec/impl/smoother/mld_z_jac_smoother_apply.f90
+18 -12
View File
@@ -46,14 +46,14 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
complex(psb_dpk_),intent(inout) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer, intent(in) :: sweeps
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer(psb_ipk_), intent(out) :: info
integer :: n_row,n_col
integer(psb_ipk_) :: n_row,n_col
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='z_jac_smoother_apply'
@@ -87,7 +87,8 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
@@ -96,7 +97,8 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
@@ -123,7 +125,8 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
allocate(tx(n_col),ty(n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/2*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
@@ -137,7 +140,8 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
! and Y(j) is the approximate solution at sweep j.
!
ty(1:n_row) = x(1:n_row)
call psb_spmm(-zone,sm%nd,tx,zone,ty,desc_data,info,work=aux,trans=trans_)
call psb_spmm(-zone,sm%nd,tx,zone,ty,desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
@@ -150,14 +154,16 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
deallocate(tx,ty,stat=info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
@@ -165,7 +171,7 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
& i_err=(/itwo,sweeps,izero,izero,izero/))
goto 9999
endif
mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90
+19 -14
View File
@@ -36,25 +36,26 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info)
use psb_base_mod
use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
type(psb_desc_type), intent(in) :: desc_data
class(mld_z_jac_smoother_type), intent(inout) :: sm
type(psb_z_vect_type),intent(inout) :: x
type(psb_z_vect_type),intent(inout) :: y
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer, intent(in) :: sweeps
complex(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
integer :: n_row,n_col
integer(psb_ipk_) :: n_row,n_col
type(psb_z_vect_type) :: tx, ty
complex(psb_dpk_), pointer :: ww(:), aux(:)
integer :: ictxt,np,me,i, err_act
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='z_jac_smoother_apply'
@@ -89,7 +90,8 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
@@ -98,7 +100,8 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
call psb_errpush(info,name,&
& i_err=(/5*n_col,izero,izero,izero,izero/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
@@ -146,7 +149,8 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
@@ -154,7 +158,8 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
if (info == psb_success_) call ty%free(info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
@@ -162,7 +167,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweep
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
& i_err=(/itwo,sweeps,izero,izero,izero/))
goto 9999
endif
mlprec/impl/smoother/mld_z_jac_smoother_bld.f90
+6 -7
View File
@@ -37,7 +37,6 @@
!!$
!!$
subroutine mld_z_jac_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
use psb_base_mod
use mld_z_diag_solver
@@ -46,17 +45,17 @@ subroutine mld_z_jac_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
! Arguments
type(psb_zspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_z_jac_smoother_type), intent(inout) :: sm
character, intent(in) :: upd
integer, intent(out) :: info
character, intent(in) :: upd
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
! Local variables
integer :: n_row,n_col, nrow_a, nztota, nzeros
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='z_jac_smoother_bld', ch_err
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='z_jac_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)