Compare commits

...

14 Commits

@ -174,13 +174,14 @@ module psb_c_base_vect_mod
!
! Vector-Vector operations
!
procedure, pass(x) :: div_v => c_base_div_v
procedure, pass(x) :: div_v_check => c_base_div_v_check
procedure, pass(y) :: div_v => c_base_div_v
procedure, pass(y) :: div_a => c_base_div_a
procedure, pass(y) :: div_v_check => c_base_div_v_check
procedure, pass(z) :: div_v2 => c_base_div_v2
procedure, pass(z) :: div_v2_check => c_base_div_v2_check
procedure, pass(z) :: div_a2 => c_base_div_a2
procedure, pass(z) :: div_a2_check => c_base_div_a2_check
generic, public :: div => div_v, div_v2, div_v_check, &
generic, public :: div => div_v, div_v2, div_v_check, div_a, &
div_v2_check, div_a2, div_a2_check
procedure, pass(y) :: inv_v => c_base_inv_v
procedure, pass(y) :: inv_v_check => c_base_inv_v_check
@ -1443,9 +1444,28 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%div(x%v,y%v,info)
call y%div(x%v,info)
end subroutine c_base_div_v
subroutine c_base_div_a(x, y, info)
use psi_serial_mod
implicit none
complex(psb_spk_), intent(in) :: x(:)
class(psb_c_base_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (y%is_dev()) call y%sync()
n = min(size(y%v), size(x))
!$omp parallel do private(i)
do i=1, n
y%v(i) = y%v(i)/x(i)
end do
call y%set_host()
end subroutine c_base_div_a
!
!> Function base_div_v2
!! \memberof psb_c_base_vect_type
@ -1463,10 +1483,10 @@ contains
integer(psb_ipk_) :: i, n
info = 0
if (z%is_dev()) call z%sync()
if (x%is_dev()) call x%sync()
if (y%is_dev()) call y%sync()
call z%div(x%v,y%v,info)
call x%set_host()
end subroutine c_base_div_v2
!
!> Function base_div_v_check
@ -1486,6 +1506,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
if (y%is_dev()) call y%sync()
call x%div(x%v,y%v,info,flag)
end subroutine c_base_div_v_check

@ -113,10 +113,10 @@ module psb_c_vect_mod
procedure, pass(z) :: mlt_av => c_vect_mlt_av
generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
& mlt_v_2, mlt_av, mlt_va
procedure, pass(x) :: div_v => c_vect_div_v
procedure, pass(y) :: div_v => c_vect_div_v
procedure, pass(z) :: div_v2 => c_vect_div_v2
procedure, pass(x) :: div_v_check => c_vect_div_v_check
procedure, pass(x) :: div_v2_check => c_vect_div_v2_check
procedure, pass(y) :: div_v_check => c_vect_div_v_check
procedure, pass(y) :: div_v2_check => c_vect_div_v2_check
procedure, pass(z) :: div_a2 => c_vect_div_a2
procedure, pass(z) :: div_a2_check => c_vect_div_a2_check
generic, public :: div => div_v, div_v2, div_v_check, &
@ -926,7 +926,7 @@ contains
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call x%v%div(y%v,info)
& call y%v%div(x%v,info)
end subroutine c_vect_div_v
@ -956,7 +956,7 @@ contains
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call x%v%div(y%v,info,flag)
& call y%v%div(x%v,info,flag)
end subroutine c_vect_div_v_check

@ -174,13 +174,14 @@ module psb_d_base_vect_mod
!
! Vector-Vector operations
!
procedure, pass(x) :: div_v => d_base_div_v
procedure, pass(x) :: div_v_check => d_base_div_v_check
procedure, pass(y) :: div_v => d_base_div_v
procedure, pass(y) :: div_a => d_base_div_a
procedure, pass(y) :: div_v_check => d_base_div_v_check
procedure, pass(z) :: div_v2 => d_base_div_v2
procedure, pass(z) :: div_v2_check => d_base_div_v2_check
procedure, pass(z) :: div_a2 => d_base_div_a2
procedure, pass(z) :: div_a2_check => d_base_div_a2_check
generic, public :: div => div_v, div_v2, div_v_check, &
generic, public :: div => div_v, div_v2, div_v_check, div_a, &
div_v2_check, div_a2, div_a2_check
procedure, pass(y) :: inv_v => d_base_inv_v
procedure, pass(y) :: inv_v_check => d_base_inv_v_check
@ -1450,9 +1451,28 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%div(x%v,y%v,info)
call y%div(x%v,info)
end subroutine d_base_div_v
subroutine d_base_div_a(x, y, info)
use psi_serial_mod
implicit none
real(psb_dpk_), intent(in) :: x(:)
class(psb_d_base_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (y%is_dev()) call y%sync()
n = min(size(y%v), size(x))
!$omp parallel do private(i)
do i=1, n
y%v(i) = y%v(i)/x(i)
end do
call y%set_host()
end subroutine d_base_div_a
!
!> Function base_div_v2
!! \memberof psb_d_base_vect_type
@ -1470,10 +1490,10 @@ contains
integer(psb_ipk_) :: i, n
info = 0
if (z%is_dev()) call z%sync()
if (x%is_dev()) call x%sync()
if (y%is_dev()) call y%sync()
call z%div(x%v,y%v,info)
call x%set_host()
end subroutine d_base_div_v2
!
!> Function base_div_v_check
@ -1493,6 +1513,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
if (y%is_dev()) call y%sync()
call x%div(x%v,y%v,info,flag)
end subroutine d_base_div_v_check

@ -113,10 +113,10 @@ module psb_d_vect_mod
procedure, pass(z) :: mlt_av => d_vect_mlt_av
generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
& mlt_v_2, mlt_av, mlt_va
procedure, pass(x) :: div_v => d_vect_div_v
procedure, pass(y) :: div_v => d_vect_div_v
procedure, pass(z) :: div_v2 => d_vect_div_v2
procedure, pass(x) :: div_v_check => d_vect_div_v_check
procedure, pass(x) :: div_v2_check => d_vect_div_v2_check
procedure, pass(y) :: div_v_check => d_vect_div_v_check
procedure, pass(y) :: div_v2_check => d_vect_div_v2_check
procedure, pass(z) :: div_a2 => d_vect_div_a2
procedure, pass(z) :: div_a2_check => d_vect_div_a2_check
generic, public :: div => div_v, div_v2, div_v_check, &
@ -933,7 +933,7 @@ contains
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call x%v%div(y%v,info)
& call y%v%div(x%v,info)
end subroutine d_vect_div_v
@ -963,7 +963,7 @@ contains
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call x%v%div(y%v,info,flag)
& call y%v%div(x%v,info,flag)
end subroutine d_vect_div_v_check

@ -174,13 +174,14 @@ module psb_s_base_vect_mod
!
! Vector-Vector operations
!
procedure, pass(x) :: div_v => s_base_div_v
procedure, pass(x) :: div_v_check => s_base_div_v_check
procedure, pass(y) :: div_v => s_base_div_v
procedure, pass(y) :: div_a => s_base_div_a
procedure, pass(y) :: div_v_check => s_base_div_v_check
procedure, pass(z) :: div_v2 => s_base_div_v2
procedure, pass(z) :: div_v2_check => s_base_div_v2_check
procedure, pass(z) :: div_a2 => s_base_div_a2
procedure, pass(z) :: div_a2_check => s_base_div_a2_check
generic, public :: div => div_v, div_v2, div_v_check, &
generic, public :: div => div_v, div_v2, div_v_check, div_a, &
div_v2_check, div_a2, div_a2_check
procedure, pass(y) :: inv_v => s_base_inv_v
procedure, pass(y) :: inv_v_check => s_base_inv_v_check
@ -1450,9 +1451,28 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%div(x%v,y%v,info)
call y%div(x%v,info)
end subroutine s_base_div_v
subroutine s_base_div_a(x, y, info)
use psi_serial_mod
implicit none
real(psb_spk_), intent(in) :: x(:)
class(psb_s_base_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (y%is_dev()) call y%sync()
n = min(size(y%v), size(x))
!$omp parallel do private(i)
do i=1, n
y%v(i) = y%v(i)/x(i)
end do
call y%set_host()
end subroutine s_base_div_a
!
!> Function base_div_v2
!! \memberof psb_s_base_vect_type
@ -1470,10 +1490,10 @@ contains
integer(psb_ipk_) :: i, n
info = 0
if (z%is_dev()) call z%sync()
if (x%is_dev()) call x%sync()
if (y%is_dev()) call y%sync()
call z%div(x%v,y%v,info)
call x%set_host()
end subroutine s_base_div_v2
!
!> Function base_div_v_check
@ -1493,6 +1513,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
if (y%is_dev()) call y%sync()
call x%div(x%v,y%v,info,flag)
end subroutine s_base_div_v_check

@ -113,10 +113,10 @@ module psb_s_vect_mod
procedure, pass(z) :: mlt_av => s_vect_mlt_av
generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
& mlt_v_2, mlt_av, mlt_va
procedure, pass(x) :: div_v => s_vect_div_v
procedure, pass(y) :: div_v => s_vect_div_v
procedure, pass(z) :: div_v2 => s_vect_div_v2
procedure, pass(x) :: div_v_check => s_vect_div_v_check
procedure, pass(x) :: div_v2_check => s_vect_div_v2_check
procedure, pass(y) :: div_v_check => s_vect_div_v_check
procedure, pass(y) :: div_v2_check => s_vect_div_v2_check
procedure, pass(z) :: div_a2 => s_vect_div_a2
procedure, pass(z) :: div_a2_check => s_vect_div_a2_check
generic, public :: div => div_v, div_v2, div_v_check, &
@ -933,7 +933,7 @@ contains
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call x%v%div(y%v,info)
& call y%v%div(x%v,info)
end subroutine s_vect_div_v
@ -963,7 +963,7 @@ contains
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call x%v%div(y%v,info,flag)
& call y%v%div(x%v,info,flag)
end subroutine s_vect_div_v_check

@ -174,13 +174,14 @@ module psb_z_base_vect_mod
!
! Vector-Vector operations
!
procedure, pass(x) :: div_v => z_base_div_v
procedure, pass(x) :: div_v_check => z_base_div_v_check
procedure, pass(y) :: div_v => z_base_div_v
procedure, pass(y) :: div_a => z_base_div_a
procedure, pass(y) :: div_v_check => z_base_div_v_check
procedure, pass(z) :: div_v2 => z_base_div_v2
procedure, pass(z) :: div_v2_check => z_base_div_v2_check
procedure, pass(z) :: div_a2 => z_base_div_a2
procedure, pass(z) :: div_a2_check => z_base_div_a2_check
generic, public :: div => div_v, div_v2, div_v_check, &
generic, public :: div => div_v, div_v2, div_v_check, div_a, &
div_v2_check, div_a2, div_a2_check
procedure, pass(y) :: inv_v => z_base_inv_v
procedure, pass(y) :: inv_v_check => z_base_inv_v_check
@ -1443,9 +1444,28 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%div(x%v,y%v,info)
call y%div(x%v,info)
end subroutine z_base_div_v
subroutine z_base_div_a(x, y, info)
use psi_serial_mod
implicit none
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (y%is_dev()) call y%sync()
n = min(size(y%v), size(x))
!$omp parallel do private(i)
do i=1, n
y%v(i) = y%v(i)/x(i)
end do
call y%set_host()
end subroutine z_base_div_a
!
!> Function base_div_v2
!! \memberof psb_z_base_vect_type
@ -1463,10 +1483,10 @@ contains
integer(psb_ipk_) :: i, n
info = 0
if (z%is_dev()) call z%sync()
if (x%is_dev()) call x%sync()
if (y%is_dev()) call y%sync()
call z%div(x%v,y%v,info)
call x%set_host()
end subroutine z_base_div_v2
!
!> Function base_div_v_check
@ -1486,6 +1506,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
if (y%is_dev()) call y%sync()
call x%div(x%v,y%v,info,flag)
end subroutine z_base_div_v_check

@ -113,10 +113,10 @@ module psb_z_vect_mod
procedure, pass(z) :: mlt_av => z_vect_mlt_av
generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
& mlt_v_2, mlt_av, mlt_va
procedure, pass(x) :: div_v => z_vect_div_v
procedure, pass(y) :: div_v => z_vect_div_v
procedure, pass(z) :: div_v2 => z_vect_div_v2
procedure, pass(x) :: div_v_check => z_vect_div_v_check
procedure, pass(x) :: div_v2_check => z_vect_div_v2_check
procedure, pass(y) :: div_v_check => z_vect_div_v_check
procedure, pass(y) :: div_v2_check => z_vect_div_v2_check
procedure, pass(z) :: div_a2 => z_vect_div_a2
procedure, pass(z) :: div_a2_check => z_vect_div_a2_check
generic, public :: div => div_v, div_v2, div_v_check, &
@ -926,7 +926,7 @@ contains
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call x%v%div(y%v,info)
& call y%v%div(x%v,info)
end subroutine z_vect_div_v
@ -956,7 +956,7 @@ contains
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call x%v%div(y%v,info,flag)
& call y%v%div(x%v,info,flag)
end subroutine z_vect_div_v_check

@ -93,7 +93,7 @@ subroutine psb_cdiv_vect(x,y,desc_a,info)
end if
if(desc_a%get_local_rows() > 0) then
call x%div(y,info)
call y%div(x,info)
end if
call psb_erractionrestore(err_act)

@ -93,7 +93,7 @@ subroutine psb_ddiv_vect(x,y,desc_a,info)
end if
if(desc_a%get_local_rows() > 0) then
call x%div(y,info)
call y%div(x,info)
end if
call psb_erractionrestore(err_act)

@ -93,7 +93,7 @@ subroutine psb_sdiv_vect(x,y,desc_a,info)
end if
if(desc_a%get_local_rows() > 0) then
call x%div(y,info)
call y%div(x,info)
end if
call psb_erractionrestore(err_act)

@ -93,7 +93,7 @@ subroutine psb_zdiv_vect(x,y,desc_a,info)
end if
if(desc_a%get_local_rows() > 0) then
call x%div(y,info)
call y%div(x,info)
end if
call psb_erractionrestore(err_act)

@ -58,4 +58,7 @@ char *psb_c_pop_errmsg()
return(tmp);
}
void psb_c_print_pointer(void *p){
fprintf(stderr,"psb_c_print_pointer %p\n",p);
}
// Convertire il comunicatore fortran in comunicatore c

@ -30,6 +30,10 @@ extern "C" {
psb_i_t *ctxt;
} psb_c_ctxt;
typedef struct PSB_C_OBJTYPE {
void *item;
} psb_c_objtype;
void psb_c_check_error(psb_c_ctxt cctxt);
@ -42,6 +46,7 @@ extern "C" {
void psb_c_seterraction_print();
void psb_c_seterraction_abort();
void psb_c_print_pointer(void *p);
/* Environment routines */
void psb_c_init(psb_c_ctxt *cctxt);
void psb_c_init_from_fint(psb_c_ctxt *cctxt, psb_i_t f_comm);

@ -941,234 +941,6 @@ contains
end function psb_c_cspsm
function psb_c_cnnz(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = 0
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = psb_nnz(ap,descp,info)
end function psb_c_cnnz
function psb_c_cis_matupd(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_upd()
end function
function psb_c_cis_matasb(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_asb()
end function
function psb_c_cis_matbld(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_bld()
end function
function psb_c_cset_matupd(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_upd()
res = psb_success_
end function
function psb_c_cset_matasb(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
res = -1;
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_asb()
res = psb_success_
end function
function psb_c_cset_matbld(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_bld()
res = psb_success_
end function
function psb_c_ccopy_mat(ah,bh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah,bh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap,bp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
if (c_associated(bh%item)) then
call c_f_pointer(bh%item,bp)
else
return
end if
call ap%clone(bp,info)
res = info
end function
function psb_c_cspscal(alpha,ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res

@ -273,4 +273,232 @@ contains
res = xp%get_entry((index+(1-ixb)))
end function psb_c_cvect_get_entry
function psb_c_cnnz(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = 0
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = psb_nnz(ap,descp,info)
end function psb_c_cnnz
function psb_c_cis_matupd(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_upd()
end function
function psb_c_cis_matasb(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_asb()
end function
function psb_c_cis_matbld(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_bld()
end function
function psb_c_cset_matupd(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_upd()
res = psb_success_
end function
function psb_c_cset_matasb(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
res = -1;
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_asb()
res = psb_success_
end function
function psb_c_cset_matbld(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_bld()
res = psb_success_
end function
function psb_c_ccopy_mat(ah,bh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cspmat) :: ah,bh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap,bp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
if (c_associated(bh%item)) then
call c_f_pointer(bh%item,bp)
else
return
end if
call ap%clone(bp,info)
res = info
end function
end module psb_c_serial_cbind_mod

@ -1042,234 +1042,6 @@ contains
end function psb_c_dspsm
function psb_c_dnnz(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = 0
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = psb_nnz(ap,descp,info)
end function psb_c_dnnz
function psb_c_dis_matupd(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_upd()
end function
function psb_c_dis_matasb(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_asb()
end function
function psb_c_dis_matbld(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_bld()
end function
function psb_c_dset_matupd(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_upd()
res = psb_success_
end function
function psb_c_dset_matasb(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
res = -1;
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_asb()
res = psb_success_
end function
function psb_c_dset_matbld(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_bld()
res = psb_success_
end function
function psb_c_dcopy_mat(ah,bh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah,bh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap,bp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
if (c_associated(bh%item)) then
call c_f_pointer(bh%item,bp)
else
return
end if
call ap%clone(bp,info)
res = info
end function
function psb_c_dspscal(alpha,ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res

@ -273,4 +273,232 @@ contains
res = xp%get_entry((index+(1-ixb)))
end function psb_c_dvect_get_entry
function psb_c_dnnz(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = 0
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = psb_nnz(ap,descp,info)
end function psb_c_dnnz
function psb_c_dis_matupd(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_upd()
end function
function psb_c_dis_matasb(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_asb()
end function
function psb_c_dis_matbld(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_bld()
end function
function psb_c_dset_matupd(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_upd()
res = psb_success_
end function
function psb_c_dset_matasb(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
res = -1;
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_asb()
res = psb_success_
end function
function psb_c_dset_matbld(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_bld()
res = psb_success_
end function
function psb_c_dcopy_mat(ah,bh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dspmat) :: ah,bh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap,bp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
if (c_associated(bh%item)) then
call c_f_pointer(bh%item,bp)
else
return
end if
call ap%clone(bp,info)
res = info
end function
end module psb_d_serial_cbind_mod

@ -42,4 +42,15 @@ module psb_objhandle_mod
type(c_ptr) :: item = c_null_ptr
end type psb_c_zspmat
interface
subroutine psb_c_print_pointer(p) bind(c,name='psb_c_print_pointer')
use iso_c_binding
type(c_ptr), value :: p
end subroutine psb_c_print_pointer
end interface
contains
function psb_c_get_new_object() result(res)
type(psb_c_object_type) :: res
res%item = c_null_ptr
end function psb_c_get_new_object
end module psb_objhandle_mod

@ -1042,234 +1042,6 @@ contains
end function psb_c_sspsm
function psb_c_snnz(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = 0
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = psb_nnz(ap,descp,info)
end function psb_c_snnz
function psb_c_sis_matupd(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_upd()
end function
function psb_c_sis_matasb(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_asb()
end function
function psb_c_sis_matbld(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_bld()
end function
function psb_c_sset_matupd(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_upd()
res = psb_success_
end function
function psb_c_sset_matasb(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
res = -1;
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_asb()
res = psb_success_
end function
function psb_c_sset_matbld(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_bld()
res = psb_success_
end function
function psb_c_scopy_mat(ah,bh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah,bh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap,bp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
if (c_associated(bh%item)) then
call c_f_pointer(bh%item,bp)
else
return
end if
call ap%clone(bp,info)
res = info
end function
function psb_c_sspscal(alpha,ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res

@ -273,4 +273,232 @@ contains
res = xp%get_entry((index+(1-ixb)))
end function psb_c_svect_get_entry
function psb_c_snnz(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = 0
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = psb_nnz(ap,descp,info)
end function psb_c_snnz
function psb_c_sis_matupd(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_upd()
end function
function psb_c_sis_matasb(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_asb()
end function
function psb_c_sis_matbld(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_bld()
end function
function psb_c_sset_matupd(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_upd()
res = psb_success_
end function
function psb_c_sset_matasb(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
res = -1;
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_asb()
res = psb_success_
end function
function psb_c_sset_matbld(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_bld()
res = psb_success_
end function
function psb_c_scopy_mat(ah,bh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_sspmat) :: ah,bh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap,bp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
if (c_associated(bh%item)) then
call c_f_pointer(bh%item,bp)
else
return
end if
call ap%clone(bp,info)
res = info
end function
end module psb_s_serial_cbind_mod

@ -941,234 +941,6 @@ contains
end function psb_c_zspsm
function psb_c_znnz(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = 0
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = psb_nnz(ap,descp,info)
end function psb_c_znnz
function psb_c_zis_matupd(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_upd()
end function
function psb_c_zis_matasb(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_asb()
end function
function psb_c_zis_matbld(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_bld()
end function
function psb_c_zset_matupd(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_upd()
res = psb_success_
end function
function psb_c_zset_matasb(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
res = -1;
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_asb()
res = psb_success_
end function
function psb_c_zset_matbld(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_bld()
res = psb_success_
end function
function psb_c_zcopy_mat(ah,bh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah,bh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap,bp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
if (c_associated(bh%item)) then
call c_f_pointer(bh%item,bp)
else
return
end if
call ap%clone(bp,info)
res = info
end function
function psb_c_zspscal(alpha,ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res

@ -273,4 +273,232 @@ contains
res = xp%get_entry((index+(1-ixb)))
end function psb_c_zvect_get_entry
function psb_c_znnz(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = 0
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = psb_nnz(ap,descp,info)
end function psb_c_znnz
function psb_c_zis_matupd(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_upd()
end function
function psb_c_zis_matasb(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_asb()
end function
function psb_c_zis_matbld(ah,cdh) bind(c) result(res)
implicit none
logical(c_bool) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
integer(psb_c_ipk_) :: info
res = .false.
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
res = ap%is_bld()
end function
function psb_c_zset_matupd(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_upd()
res = psb_success_
end function
function psb_c_zset_matasb(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
res = -1;
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_asb()
res = psb_success_
end function
function psb_c_zset_matbld(ah,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
call ap%set_bld()
res = psb_success_
end function
function psb_c_zcopy_mat(ah,bh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zspmat) :: ah,bh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap,bp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(ah%item)) then
call c_f_pointer(ah%item,ap)
else
return
end if
if (c_associated(bh%item)) then
call c_f_pointer(bh%item,bp)
else
return
end if
call ap%clone(bp,info)
res = info
end function
end module psb_z_serial_cbind_mod

@ -6,6 +6,7 @@ module psb_base_linsolve_cbind_mod
type, bind(c) :: solveroptions
integer(psb_c_ipk_) :: iter, itmax, itrace, irst, istop
real(c_double) :: eps, err
type(psb_c_object_type) :: s1, s2
end type solveroptions
contains
@ -20,7 +21,8 @@ contains
options%istop = 2
options%irst = 10
options%eps = 1.d-6
options%s1 = psb_c_get_new_object()
options%s2 = psb_c_get_new_object()
res = 0
end function psb_c_DefaultSolverOptions
@ -30,12 +32,15 @@ contains
type(solveroptions), value :: options
integer(psb_c_ipk_) :: res
write(*,*) 'PSBLAS C Interface Solver Options '
write(*,*) ' Maximum number of iterations :', options%itmax
write(*,*) ' Tracing :', options%itrace
write(*,*) ' Stopping Criterion :', options%istop
write(*,*) ' Restart :', options%irst
write(*,*) ' EPS (tolerance) :', options%eps
write(0,*) 'PSBLAS C Interface Solver Options '
write(0,*) ' Maximum number of iterations :', options%itmax
write(0,*) ' Tracing :', options%itrace
write(0,*) ' Stopping Criterion :', options%istop
write(0,*) ' Restart :', options%irst
write(0,*) ' EPS (tolerance) :', options%eps
write(0,*) ' S1 scaling :', c_associated(options%s1%item)
write(0,*) ' S2 scaling :', c_associated(options%s2%item)
res = 0
end function psb_c_PrintSolverOptions

@ -24,13 +24,14 @@ contains
res= psb_c_ckrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh, &
& itmax=options%itmax, iter=options%iter,&
& itrace=options%itrace, istop=options%istop,&
& irst=options%irst, err=options%err)
& irst=options%irst, err=options%err, s1=options%s1,s2=options%s2)
end function psb_c_ckrylov
function psb_c_ckrylov_opt(methd,&
& ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res)
& ah,ph,bh,xh,eps,cdh,itmax,iter,&
& err,itrace,irst,istop,s1,s2) bind(c) result(res)
use psb_base_mod
use psb_error_mod
use psb_prec_mod
@ -49,10 +50,12 @@ contains
integer(psb_c_ipk_) :: iter
real(c_double) :: err
character(c_char) :: methd(*)
type(psb_c_object_type) :: s1,s2
type(psb_desc_type), pointer :: descp
type(psb_cspmat_type), pointer :: ap
type(psb_cprec_type), pointer :: precp
type(psb_c_vect_type), pointer :: xp, bp
type(psb_c_vect_type), pointer :: xp, bp, s1p, s2p
integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter,err_act
character(len=20) :: fmethd
@ -84,6 +87,16 @@ contains
else
return
end if
if (c_associated(s1%item)) then
call c_f_pointer(s1%item,s1p)
else
nullify(s1p)
end if
if (c_associated(s2%item)) then
call c_f_pointer(s2%item,s2p)
else
nullify(s2p)
end if
call stringc2f(methd,fmethd)
@ -94,10 +107,27 @@ contains
fistop = istop
err_act = psb_act_abort_
if (psb_errstatus_fatal()) call psb_error_handler(err_act)
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
if (associated(s1p).and.associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p,s2=s2p)
else if (associated(s1p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p)
else if (associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s2=s2p)
else
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
end if
iter = fiter
err = ferr
res = info

@ -24,13 +24,14 @@ contains
res= psb_c_dkrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh, &
& itmax=options%itmax, iter=options%iter,&
& itrace=options%itrace, istop=options%istop,&
& irst=options%irst, err=options%err)
& irst=options%irst, err=options%err, s1=options%s1,s2=options%s2)
end function psb_c_dkrylov
function psb_c_dkrylov_opt(methd,&
& ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res)
& ah,ph,bh,xh,eps,cdh,itmax,iter,&
& err,itrace,irst,istop,s1,s2) bind(c) result(res)
use psb_base_mod
use psb_error_mod
use psb_prec_mod
@ -49,10 +50,12 @@ contains
integer(psb_c_ipk_) :: iter
real(c_double) :: err
character(c_char) :: methd(*)
type(psb_c_object_type) :: s1,s2
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
type(psb_dprec_type), pointer :: precp
type(psb_d_vect_type), pointer :: xp, bp
type(psb_d_vect_type), pointer :: xp, bp, s1p, s2p
integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter,err_act
character(len=20) :: fmethd
@ -84,6 +87,16 @@ contains
else
return
end if
if (c_associated(s1%item)) then
call c_f_pointer(s1%item,s1p)
else
nullify(s1p)
end if
if (c_associated(s2%item)) then
call c_f_pointer(s2%item,s2p)
else
nullify(s2p)
end if
call stringc2f(methd,fmethd)
@ -94,10 +107,27 @@ contains
fistop = istop
err_act = psb_act_abort_
if (psb_errstatus_fatal()) call psb_error_handler(err_act)
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
if (associated(s1p).and.associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p,s2=s2p)
else if (associated(s1p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p)
else if (associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s2=s2p)
else
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
end if
iter = fiter
err = ferr
res = info

@ -22,6 +22,8 @@ typedef struct psb_c_solveroptions {
int istop; /* Stopping criterion: 1:backward error 2: ||r||_2/||b||_2 */
double eps; /* Stopping tolerance */
double err; /* Convergence indicator on exit */
void *s1;
void *s2;
} psb_c_SolverOptions;
int psb_c_DefaultSolverOptions(psb_c_SolverOptions *opt);

@ -24,13 +24,14 @@ contains
res= psb_c_skrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh, &
& itmax=options%itmax, iter=options%iter,&
& itrace=options%itrace, istop=options%istop,&
& irst=options%irst, err=options%err)
& irst=options%irst, err=options%err, s1=options%s1,s2=options%s2)
end function psb_c_skrylov
function psb_c_skrylov_opt(methd,&
& ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res)
& ah,ph,bh,xh,eps,cdh,itmax,iter,&
& err,itrace,irst,istop,s1,s2) bind(c) result(res)
use psb_base_mod
use psb_error_mod
use psb_prec_mod
@ -49,10 +50,12 @@ contains
integer(psb_c_ipk_) :: iter
real(c_double) :: err
character(c_char) :: methd(*)
type(psb_c_object_type) :: s1,s2
type(psb_desc_type), pointer :: descp
type(psb_sspmat_type), pointer :: ap
type(psb_sprec_type), pointer :: precp
type(psb_s_vect_type), pointer :: xp, bp
type(psb_s_vect_type), pointer :: xp, bp, s1p, s2p
integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter,err_act
character(len=20) :: fmethd
@ -84,6 +87,16 @@ contains
else
return
end if
if (c_associated(s1%item)) then
call c_f_pointer(s1%item,s1p)
else
nullify(s1p)
end if
if (c_associated(s2%item)) then
call c_f_pointer(s2%item,s2p)
else
nullify(s2p)
end if
call stringc2f(methd,fmethd)
@ -94,10 +107,27 @@ contains
fistop = istop
err_act = psb_act_abort_
if (psb_errstatus_fatal()) call psb_error_handler(err_act)
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
if (associated(s1p).and.associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p,s2=s2p)
else if (associated(s1p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p)
else if (associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s2=s2p)
else
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
end if
iter = fiter
err = ferr
res = info

@ -24,13 +24,14 @@ contains
res= psb_c_zkrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh, &
& itmax=options%itmax, iter=options%iter,&
& itrace=options%itrace, istop=options%istop,&
& irst=options%irst, err=options%err)
& irst=options%irst, err=options%err, s1=options%s1,s2=options%s2)
end function psb_c_zkrylov
function psb_c_zkrylov_opt(methd,&
& ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res)
& ah,ph,bh,xh,eps,cdh,itmax,iter,&
& err,itrace,irst,istop,s1,s2) bind(c) result(res)
use psb_base_mod
use psb_error_mod
use psb_prec_mod
@ -49,10 +50,12 @@ contains
integer(psb_c_ipk_) :: iter
real(c_double) :: err
character(c_char) :: methd(*)
type(psb_c_object_type) :: s1,s2
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
type(psb_zprec_type), pointer :: precp
type(psb_z_vect_type), pointer :: xp, bp
type(psb_z_vect_type), pointer :: xp, bp, s1p, s2p
integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter,err_act
character(len=20) :: fmethd
@ -84,6 +87,16 @@ contains
else
return
end if
if (c_associated(s1%item)) then
call c_f_pointer(s1%item,s1p)
else
nullify(s1p)
end if
if (c_associated(s2%item)) then
call c_f_pointer(s2%item,s2p)
else
nullify(s2p)
end if
call stringc2f(methd,fmethd)
@ -94,10 +107,27 @@ contains
fistop = istop
err_act = psb_act_abort_
if (psb_errstatus_fatal()) call psb_error_handler(err_act)
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
if (associated(s1p).and.associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p,s2=s2p)
else if (associated(s1p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p)
else if (associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s2=s2p)
else
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, info,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
end if
iter = fiter
err = ferr
res = info

@ -9,6 +9,8 @@ MODDIR=../modules
MODOBJS= psb_base_linsolve_conv_mod.o \
psb_s_linsolve_conv_mod.o psb_c_linsolve_conv_mod.o \
psb_d_linsolve_conv_mod.o psb_z_linsolve_conv_mod.o \
psb_s_linsolve_mod.o psb_c_linsolve_mod.o \
psb_d_linsolve_mod.o psb_z_linsolve_mod.o \
psb_linsolve_mod.o
OBJS=$(MODOBJS)
@ -37,6 +39,9 @@ impld: $(OBJS)
psb_s_linsolve_conv_mod.o psb_c_linsolve_conv_mod.o psb_d_linsolve_conv_mod.o psb_z_linsolve_conv_mod.o: psb_base_linsolve_conv_mod.o
psb_linsolve_conv_mod.o: psb_s_linsolve_conv_mod.o psb_c_linsolve_conv_mod.o psb_d_linsolve_conv_mod.o psb_z_linsolve_conv_mod.o
psb_linsolve_mod.o: psb_s_linsolve_mod.o psb_c_linsolve_mod.o psb_d_linsolve_mod.o psb_z_linsolve_mod.o
$(F90OBJS): $(MODOBJS)
$(OBJS): $(MODDIR)/$(PRECMODNAME)$(.mod) $(MODDIR)/$(BASEMODNAME)$(.mod)

@ -95,7 +95,7 @@
!
subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
& itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_c_linsolve_conv_mod
@ -111,6 +111,7 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(in) :: itmax, itrace, istop
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_spk_), optional, intent(out) :: err
type(psb_c_vect_type), intent(inout), optional :: s1, s2
! !$ local data
complex(psb_spk_), allocatable, target :: aux(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
@ -160,19 +161,29 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
! istop_ = 2: ||r||/||b|| norm 2
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
info=psb_err_invalid_istop_
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
endif
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if(info /= psb_success_) then
@ -226,7 +237,8 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -252,7 +264,7 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
rho = czero
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -306,7 +318,7 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,q,cone,r,desc_a,info)
call psb_geaxpby(-alpha,qt,cone,rt,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -96,7 +96,7 @@
!
!
subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
& itmax,iter,err,itrace,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_c_linsolve_conv_mod
@ -112,6 +112,8 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
type(psb_c_vect_type), intent(inout), optional :: s1, s2
! = Local data
complex(psb_spk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
@ -159,8 +161,29 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
@ -224,7 +247,8 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
rho = czero
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
&desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -268,7 +292,7 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(alpha,p,cone,x,desc_a,info)
call psb_geaxpby(-alpha,q,cone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -93,7 +93,7 @@
! estimate of) residual.
!
Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
& itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_c_linsolve_conv_mod
@ -109,6 +109,7 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_c_vect_type), intent(inout), optional :: s1, s2
! = local data
complex(psb_spk_), allocatable, target :: aux(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
@ -154,8 +155,29 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
istop_ = psb_get_istop_default()
Endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info)
@ -202,7 +224,8 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -225,7 +248,7 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -299,7 +322,7 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -93,7 +93,7 @@
! where r is the (preconditioned, recursive
! estimate of) residual.
!
Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_c_linsolve_conv_mod
@ -109,6 +109,7 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_c_vect_type), intent(inout), optional :: s1, s2
! = Local data
complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:)
type(psb_c_vect_type) :: q, r, p, v, s, t, z, f
@ -156,13 +157,31 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
Endif
else
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b|| norm 2
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
! = if (.not.same_type_as(x,b)) then
! = write(0,*) 'Warning: different dynamic types for X and B '
! = end if
@ -217,7 +236,8 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
End If
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -234,7 +254,7 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(cone,r,czero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
@ -354,7 +374,7 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(omega,z,cone,x,desc_a,info)
call psb_geaxpby(cone,s,czero,r,desc_a,info)
call psb_geaxpby(-omega,t,cone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_,name,a_err='X/R update ')

@ -104,7 +104,7 @@
!
!
Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
& itmax,iter,err,itrace,irst,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_c_linsolve_conv_mod
@ -120,6 +120,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_c_vect_type), intent(inout), optional :: s1, s2
! = local data
complex(psb_spk_), allocatable, target :: aux(:), gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
@ -172,8 +173,29 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
if (present(itmax)) then
itmax_ = itmax
@ -246,7 +268,8 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
rt0 => wwrk(10)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -284,7 +307,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',b%get_nrows()
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -388,7 +411,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-gamma1(j),rh(j),cone,rh(0),desc_a,info)
enddo
if (psb_check_conv(methdname,itx,x,rh(0),desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,rh(0),desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -104,7 +104,7 @@
!
!
subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
& itmax,iter,err,itrace,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_c_linsolve_conv_mod
@ -120,6 +120,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
real(psb_spk_), Optional, Intent(out) :: err,cond
type(psb_c_vect_type), intent(inout), optional :: s1, s2
! = Local data
type(psb_c_vect_type) :: v, w, d , q, r
complex(psb_spk_) :: alpha, beta, delta, gamma, theta
@ -164,9 +165,29 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
@ -207,7 +228,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
& scratch=.true.,mold=x%v)
call psb_init_conv(methdname,istop_,itrace_,itmax_,&
& a,x,b,eps,desc_a,stopdat,info)
& a,x,b,eps,desc_a,stopdat,info,s1=s1,s2=s2)
itx = 0
restart: do
@ -226,7 +247,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) then
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) then
if (debug.and.(me==0)) write(0,*) name,' Exit on convergence from restart'
exit restart
end if
@ -282,7 +303,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) then
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) then
if (debug.and.(me==0)) write(0,*) name,' Exit on convergence from iteration'
exit restart
end if

@ -106,7 +106,7 @@
!
subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace, irst, istop)
& itmax,iter,err,itrace, irst, istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_c_linsolve_conv_mod
@ -124,6 +124,7 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
real(psb_spk_), Optional, Intent(out) :: err
type(psb_c_vect_type), intent(inout), optional :: s1, s2
! = local data
complex(psb_spk_), allocatable :: alpha(:), h(:,:)
type(psb_c_vect_type), allocatable :: z(:), c(:), c_scale(:)
@ -167,22 +168,30 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b||, 2-norm
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
endif
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
& call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info)
@ -245,7 +254,8 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
nrst = -1
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
restart: do
if (itx>= itmax_) exit restart
h = czero
@ -268,7 +278,7 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
nrst = nrst + 1
@ -299,7 +309,7 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(cone, r, czero, r, desc_a, info)
call psb_geaxpby(-alpha(j), c_scale(j), cone, r, desc_a, info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (j >= irst) exit iteration

@ -80,7 +80,7 @@
! estimate of) residual
!
Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
& itmax,iter,err,itrace,irst,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod,only : psb_cprec_type
@ -97,11 +97,12 @@ Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
type(psb_c_vect_type), intent(inout), optional :: s1, s2
abstract interface
subroutine psb_ckryl_vect(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop)
& desc_a,info,itmax,iter,err,itrace,istop,s1,s2)
import :: psb_ipk_, psb_spk_, psb_desc_type, &
& psb_cspmat_type, psb_cprec_type, psb_c_vect_type
type(psb_cspmat_type), intent(in) :: a
@ -114,9 +115,10 @@ Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_spk_), optional, intent(out) :: err
type(psb_c_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_ckryl_vect
Subroutine psb_ckryl_rest_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,irst,istop)
&itmax,iter,err, itrace,irst,istop,s1,s2)
import :: psb_ipk_, psb_spk_, psb_desc_type, &
& psb_cspmat_type, psb_cprec_type, psb_c_vect_type
Type(psb_cspmat_type), Intent(in) :: a
@ -129,9 +131,10 @@ Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_c_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_ckryl_rest_vect
Subroutine psb_ckryl_cond_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,istop,cond)
&itmax,iter,err, itrace,istop,cond,s1,s2)
import :: psb_ipk_, psb_spk_, psb_desc_type, &
& psb_cspmat_type, psb_cprec_type, psb_c_vect_type
Type(psb_cspmat_type), Intent(in) :: a
@ -144,6 +147,7 @@ Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err, cond
type(psb_c_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_ckryl_cond_vect
end interface
@ -180,34 +184,34 @@ Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
select case(psb_toupper(method))
case('CG')
call psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond)
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond,s1=s1,s2=s2)
case('FCG')
call psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond)
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond,s1=s1,s2=s2)
case('GCR')
call psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('CGS')
call psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('BICG')
call psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('BICGSTAB')
call psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('RGMRES','GMRES')
call psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop)
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop,s1=s1,s2=s2)
case('BICGSTABL')
call psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop)
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop,s1=s1,s2=s2)
case default
if (me == 0) write(psb_err_unit,*) trim(name),&
& ': Warning: Unknown method ',method,&
& ', defaulting to BiCGSTAB'
call psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
end select
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)

@ -97,17 +97,20 @@
! iterations
! istop - integer(optional) Input: stopping criterion, or how
! to estimate the error.
! 1: err = |r|/(|a||x|+|b|); here the iteration is
! 1: err = |r|/(|a||x|+|b|); here
! the iteration is
! stopped when |r| <= eps * (|a||x|+|b|)
! 2: err = |r|/|b|; here the iteration is
! stopped when |r| <= eps * |b|
! 3: Same as 2 but with X and B scaled
! by s1 and s2
! where r is the (preconditioned, recursive
! estimate of) residual.
! irst - integer(optional) Input: restart parameter
!
subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
& itmax,iter,err,itrace,irst,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_c_linsolve_conv_mod
@ -123,6 +126,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_c_vect_type), intent(inout), optional :: s1, s2
! = local data
complex(psb_spk_), allocatable :: aux(:)
complex(psb_spk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
@ -267,9 +271,20 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
select case(istop_)
case(psb_istop_ani_)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
if (present(s1)) then
call psb_gemlt(cone,s1,b,czero,v(1),desc_a,info)
bni = psb_geamax(v(1),desc_a,info)
else
bni = psb_geamax(b,desc_a,info)
end if
case(psb_istop_bn2_)
bn2 = psb_genrm2(b,desc_a,info)
if (present(s1)) then
call psb_gemlt(cone,s1,b,czero,v(1),desc_a,info)
bn2 = psb_genrm2(v(1),desc_a,info)
else
bn2 = psb_genrm2(b,desc_a,info)
end if
case(psb_istop_rn2_abs_)
! do nothing
case(psb_istop_rrn2_)
@ -281,6 +296,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
end if
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -322,7 +338,8 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_errpush(info,name)
goto 9999
end if
if (present(s1)) call psb_gemlt(s1,v(1),desc_a,info)
rs(1) = psb_genrm2(v(1),desc_a,info)
rs(2:) = czero
if (info /= psb_success_) then
@ -377,8 +394,14 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
inner: Do i=1,nl
itx = itx + 1
call prec%apply(v(i),w1,desc_a,info)
if (present(s2)) then
call psb_gediv(v(i),s2,w,desc_a,info)
call prec%apply(w,w1,desc_a,info)
else
call prec%apply(v(i),w1,desc_a,info)
end if
call psb_spmm(cone,a,w1,czero,w,desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,w,desc_a,info)
!
call mgs(i,h,v,w,rs,c,s,desc_a,info)
@ -390,10 +413,11 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
!
rst = rs
call psb_geaxpby(cone,x,czero,xt,desc_a,info)
call rebuildx(i,h,v,w,w1,xt,rst,c,s,prec,desc_a,info)
call rebuildx(i,h,v,w,w1,xt,rst,c,s,prec,desc_a,info,s2=s2)
call psb_geaxpby(cone,b,czero,w1,desc_a,info)
call psb_spmm(-cone,a,xt,cone,w1,desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,w,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@ -431,7 +455,8 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(cone,xt,czero,x,desc_a,info)
! = x = xt
case(psb_istop_bn2_, psb_istop_rn2_abs_,psb_istop_rrn2_)
call rebuildx(i,h,v,w,w1,x,rs,c,s,prec,desc_a,info) !
call rebuildx(i,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2=s2)
!
end select
@ -451,7 +476,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(cone,xt,czero,x,desc_a,info)! x = xt
case(psb_istop_bn2_, psb_istop_rn2_abs_,psb_istop_rrn2_)
call rebuildx(nl,h,v,w,w1,x,rs,c,s,prec,desc_a,info) !
call rebuildx(nl,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2=s2) !
end select
if (itx >= itmax_) then
@ -522,11 +547,12 @@ contains
! Rebuild solution X from the space V using the factor
! stored in R
!
subroutine rebuildx(n,h,v,w,w1,x,rs,c,s,prec,desc_a,info)
subroutine rebuildx(n,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2)
complex(psb_spk_) :: c(:), s(:), rs(:), h(:,:)
type(psb_c_vect_type) :: v(:), w, w1, x
type(psb_desc_type) :: desc_a
class(psb_cprec_type) :: prec
type(psb_c_vect_type), intent(inout), optional :: s2
integer(psb_ipk_) :: info
integer(psb_ipk_) :: k,n
@ -538,12 +564,13 @@ contains
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Rebuild x-> RS:',rs(1:n)
call w1%zero()
call w%zero()
do k=1, n
call psb_geaxpby(rs(k),v(k),cone,w1,desc_a,info)
call psb_geaxpby(rs(k),v(k),cone,w,desc_a,info)
end do
call prec%apply(w1,w,desc_a,info)
call psb_geaxpby(cone,w,cone,x,desc_a,info)
if (present(s2)) call psb_gediv(s2,w,desc_a,info)
call prec%apply(w,w1,desc_a,info)
call psb_geaxpby(cone,w1,cone,x,desc_a,info)
end subroutine rebuildx
end subroutine psb_crgmres_vect

@ -120,8 +120,17 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
if (present(itmax)) then
itmax_ = itmax
else

@ -95,7 +95,7 @@
!
subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
& itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_d_linsolve_conv_mod
@ -111,6 +111,7 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(in) :: itmax, itrace, istop
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
type(psb_d_vect_type), intent(inout), optional :: s1, s2
! !$ local data
real(psb_dpk_), allocatable, target :: aux(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
@ -160,19 +161,29 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
! istop_ = 2: ||r||/||b|| norm 2
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
info=psb_err_invalid_istop_
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
endif
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if(info /= psb_success_) then
@ -226,7 +237,8 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -252,7 +264,7 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
rho = dzero
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -306,7 +318,7 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,q,done,r,desc_a,info)
call psb_geaxpby(-alpha,qt,done,rt,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -96,7 +96,7 @@
!
!
subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
& itmax,iter,err,itrace,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_d_linsolve_conv_mod
@ -112,6 +112,8 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
type(psb_d_vect_type), intent(inout), optional :: s1, s2
! = Local data
real(psb_dpk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
@ -159,8 +161,29 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
@ -232,7 +255,8 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
rho = dzero
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
&desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -285,7 +309,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(alpha,p,done,x,desc_a,info)
call psb_geaxpby(-alpha,q,done,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -93,7 +93,7 @@
! estimate of) residual.
!
Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
& itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_d_linsolve_conv_mod
@ -109,6 +109,7 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_d_vect_type), intent(inout), optional :: s1, s2
! = local data
real(psb_dpk_), allocatable, target :: aux(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
@ -154,8 +155,29 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
istop_ = psb_get_istop_default()
Endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info)
@ -202,7 +224,8 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -225,7 +248,7 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -299,7 +322,7 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -93,7 +93,7 @@
! where r is the (preconditioned, recursive
! estimate of) residual.
!
Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_d_linsolve_conv_mod
@ -109,6 +109,7 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_d_vect_type), intent(inout), optional :: s1, s2
! = Local data
real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
type(psb_d_vect_type) :: q, r, p, v, s, t, z, f
@ -156,13 +157,31 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
Endif
else
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b|| norm 2
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
! = if (.not.same_type_as(x,b)) then
! = write(0,*) 'Warning: different dynamic types for X and B '
! = end if
@ -217,7 +236,8 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
End If
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -234,7 +254,7 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(done,r,dzero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
@ -354,7 +374,7 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(omega,z,done,x,desc_a,info)
call psb_geaxpby(done,s,dzero,r,desc_a,info)
call psb_geaxpby(-omega,t,done,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_,name,a_err='X/R update ')

@ -104,7 +104,7 @@
!
!
Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
& itmax,iter,err,itrace,irst,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_d_linsolve_conv_mod
@ -120,6 +120,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_d_vect_type), intent(inout), optional :: s1, s2
! = local data
real(psb_dpk_), allocatable, target :: aux(:), gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
@ -172,8 +173,29 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
if (present(itmax)) then
itmax_ = itmax
@ -246,7 +268,8 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
rt0 => wwrk(10)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -284,7 +307,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',b%get_nrows()
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -388,7 +411,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-gamma1(j),rh(j),done,rh(0),desc_a,info)
enddo
if (psb_check_conv(methdname,itx,x,rh(0),desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,rh(0),desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -104,7 +104,7 @@
!
!
subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
& itmax,iter,err,itrace,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_d_linsolve_conv_mod
@ -120,6 +120,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
real(psb_dpk_), Optional, Intent(out) :: err,cond
type(psb_d_vect_type), intent(inout), optional :: s1, s2
! = Local data
type(psb_d_vect_type) :: v, w, d , q, r
real(psb_dpk_) :: alpha, beta, delta, gamma, theta
@ -164,9 +165,29 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
@ -207,7 +228,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
& scratch=.true.,mold=x%v)
call psb_init_conv(methdname,istop_,itrace_,itmax_,&
& a,x,b,eps,desc_a,stopdat,info)
& a,x,b,eps,desc_a,stopdat,info,s1=s1,s2=s2)
itx = 0
restart: do
@ -226,7 +247,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) then
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) then
if (debug.and.(me==0)) write(0,*) name,' Exit on convergence from restart'
exit restart
end if
@ -282,7 +303,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) then
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) then
if (debug.and.(me==0)) write(0,*) name,' Exit on convergence from iteration'
exit restart
end if

@ -106,7 +106,7 @@
!
subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace, irst, istop)
& itmax,iter,err,itrace, irst, istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_d_linsolve_conv_mod
@ -124,6 +124,7 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
real(psb_dpk_), Optional, Intent(out) :: err
type(psb_d_vect_type), intent(inout), optional :: s1, s2
! = local data
real(psb_dpk_), allocatable :: alpha(:), h(:,:)
type(psb_d_vect_type), allocatable :: z(:), c(:), c_scale(:)
@ -167,22 +168,30 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b||, 2-norm
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
endif
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
& call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info)
@ -245,7 +254,8 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
nrst = -1
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
restart: do
if (itx>= itmax_) exit restart
h = dzero
@ -268,7 +278,7 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
nrst = nrst + 1
@ -299,7 +309,7 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(done, r, dzero, r, desc_a, info)
call psb_geaxpby(-alpha(j), c_scale(j), done, r, desc_a, info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (j >= irst) exit iteration

@ -80,7 +80,7 @@
! estimate of) residual
!
Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
& itmax,iter,err,itrace,irst,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod,only : psb_dprec_type
@ -97,11 +97,12 @@ Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
type(psb_d_vect_type), intent(inout), optional :: s1, s2
abstract interface
subroutine psb_dkryl_vect(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop)
& desc_a,info,itmax,iter,err,itrace,istop,s1,s2)
import :: psb_ipk_, psb_dpk_, psb_desc_type, &
& psb_dspmat_type, psb_dprec_type, psb_d_vect_type
type(psb_dspmat_type), intent(in) :: a
@ -114,9 +115,10 @@ Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
type(psb_d_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_dkryl_vect
Subroutine psb_dkryl_rest_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,irst,istop)
&itmax,iter,err, itrace,irst,istop,s1,s2)
import :: psb_ipk_, psb_dpk_, psb_desc_type, &
& psb_dspmat_type, psb_dprec_type, psb_d_vect_type
Type(psb_dspmat_type), Intent(in) :: a
@ -129,9 +131,10 @@ Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_d_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_dkryl_rest_vect
Subroutine psb_dkryl_cond_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,istop,cond)
&itmax,iter,err, itrace,istop,cond,s1,s2)
import :: psb_ipk_, psb_dpk_, psb_desc_type, &
& psb_dspmat_type, psb_dprec_type, psb_d_vect_type
Type(psb_dspmat_type), Intent(in) :: a
@ -144,6 +147,7 @@ Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err, cond
type(psb_d_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_dkryl_cond_vect
end interface
@ -180,34 +184,34 @@ Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
select case(psb_toupper(method))
case('CG')
call psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond)
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond,s1=s1,s2=s2)
case('FCG')
call psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond)
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond,s1=s1,s2=s2)
case('GCR')
call psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('CGS')
call psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('BICG')
call psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('BICGSTAB')
call psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('RGMRES','GMRES')
call psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop)
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop,s1=s1,s2=s2)
case('BICGSTABL')
call psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop)
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop,s1=s1,s2=s2)
case default
if (me == 0) write(psb_err_unit,*) trim(name),&
& ': Warning: Unknown method ',method,&
& ', defaulting to BiCGSTAB'
call psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
end select
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)

@ -97,17 +97,20 @@
! iterations
! istop - integer(optional) Input: stopping criterion, or how
! to estimate the error.
! 1: err = |r|/(|a||x|+|b|); here the iteration is
! 1: err = |r|/(|a||x|+|b|); here
! the iteration is
! stopped when |r| <= eps * (|a||x|+|b|)
! 2: err = |r|/|b|; here the iteration is
! stopped when |r| <= eps * |b|
! 3: Same as 2 but with X and B scaled
! by s1 and s2
! where r is the (preconditioned, recursive
! estimate of) residual.
! irst - integer(optional) Input: restart parameter
!
subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
& itmax,iter,err,itrace,irst,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_d_linsolve_conv_mod
@ -123,6 +126,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_d_vect_type), intent(inout), optional :: s1, s2
! = local data
real(psb_dpk_), allocatable :: aux(:)
real(psb_dpk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
@ -267,9 +271,20 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
select case(istop_)
case(psb_istop_ani_)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
if (present(s1)) then
call psb_gemlt(done,s1,b,dzero,v(1),desc_a,info)
bni = psb_geamax(v(1),desc_a,info)
else
bni = psb_geamax(b,desc_a,info)
end if
case(psb_istop_bn2_)
bn2 = psb_genrm2(b,desc_a,info)
if (present(s1)) then
call psb_gemlt(done,s1,b,dzero,v(1),desc_a,info)
bn2 = psb_genrm2(v(1),desc_a,info)
else
bn2 = psb_genrm2(b,desc_a,info)
end if
case(psb_istop_rn2_abs_)
! do nothing
case(psb_istop_rrn2_)
@ -281,6 +296,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
end if
call psb_spmm(-done,a,x,done,v(1),desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -322,7 +338,8 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_errpush(info,name)
goto 9999
end if
if (present(s1)) call psb_gemlt(s1,v(1),desc_a,info)
rs(1) = psb_genrm2(v(1),desc_a,info)
rs(2:) = dzero
if (info /= psb_success_) then
@ -377,8 +394,14 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
inner: Do i=1,nl
itx = itx + 1
call prec%apply(v(i),w1,desc_a,info)
if (present(s2)) then
call psb_gediv(v(i),s2,w,desc_a,info)
call prec%apply(w,w1,desc_a,info)
else
call prec%apply(v(i),w1,desc_a,info)
end if
call psb_spmm(done,a,w1,dzero,w,desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,w,desc_a,info)
!
call mgs(i,h,v,w,rs,c,s,desc_a,info)
@ -390,10 +413,11 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
!
rst = rs
call psb_geaxpby(done,x,dzero,xt,desc_a,info)
call rebuildx(i,h,v,w,w1,xt,rst,c,s,prec,desc_a,info)
call rebuildx(i,h,v,w,w1,xt,rst,c,s,prec,desc_a,info,s2=s2)
call psb_geaxpby(done,b,dzero,w1,desc_a,info)
call psb_spmm(-done,a,xt,done,w1,desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,w,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@ -431,7 +455,8 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(done,xt,dzero,x,desc_a,info)
! = x = xt
case(psb_istop_bn2_, psb_istop_rn2_abs_,psb_istop_rrn2_)
call rebuildx(i,h,v,w,w1,x,rs,c,s,prec,desc_a,info) !
call rebuildx(i,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2=s2)
!
end select
@ -451,7 +476,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(done,xt,dzero,x,desc_a,info)! x = xt
case(psb_istop_bn2_, psb_istop_rn2_abs_,psb_istop_rrn2_)
call rebuildx(nl,h,v,w,w1,x,rs,c,s,prec,desc_a,info) !
call rebuildx(nl,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2=s2) !
end select
if (itx >= itmax_) then
@ -522,11 +547,12 @@ contains
! Rebuild solution X from the space V using the factor
! stored in R
!
subroutine rebuildx(n,h,v,w,w1,x,rs,c,s,prec,desc_a,info)
subroutine rebuildx(n,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2)
real(psb_dpk_) :: c(:), s(:), rs(:), h(:,:)
type(psb_d_vect_type) :: v(:), w, w1, x
type(psb_desc_type) :: desc_a
class(psb_dprec_type) :: prec
type(psb_d_vect_type), intent(inout), optional :: s2
integer(psb_ipk_) :: info
integer(psb_ipk_) :: k,n
@ -538,12 +564,13 @@ contains
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Rebuild x-> RS:',rs(1:n)
call w1%zero()
call w%zero()
do k=1, n
call psb_geaxpby(rs(k),v(k),done,w1,desc_a,info)
call psb_geaxpby(rs(k),v(k),done,w,desc_a,info)
end do
call prec%apply(w1,w,desc_a,info)
call psb_geaxpby(done,w,done,x,desc_a,info)
if (present(s2)) call psb_gediv(s2,w,desc_a,info)
call prec%apply(w,w1,desc_a,info)
call psb_geaxpby(done,w1,done,x,desc_a,info)
end subroutine rebuildx
end subroutine psb_drgmres_vect

@ -120,8 +120,17 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
if (present(itmax)) then
itmax_ = itmax
else

@ -95,7 +95,7 @@
!
subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
& itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_s_linsolve_conv_mod
@ -111,6 +111,7 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(in) :: itmax, itrace, istop
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_spk_), optional, intent(out) :: err
type(psb_s_vect_type), intent(inout), optional :: s1, s2
! !$ local data
real(psb_spk_), allocatable, target :: aux(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
@ -160,19 +161,29 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
! istop_ = 2: ||r||/||b|| norm 2
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
info=psb_err_invalid_istop_
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
endif
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if(info /= psb_success_) then
@ -226,7 +237,8 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -252,7 +264,7 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
rho = szero
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -306,7 +318,7 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,q,sone,r,desc_a,info)
call psb_geaxpby(-alpha,qt,sone,rt,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -96,7 +96,7 @@
!
!
subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
& itmax,iter,err,itrace,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_s_linsolve_conv_mod
@ -112,6 +112,8 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
type(psb_s_vect_type), intent(inout), optional :: s1, s2
! = Local data
real(psb_spk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
@ -159,8 +161,29 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
@ -232,7 +255,8 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
rho = szero
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
&desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -285,7 +309,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(alpha,p,sone,x,desc_a,info)
call psb_geaxpby(-alpha,q,sone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -93,7 +93,7 @@
! estimate of) residual.
!
Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
& itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_s_linsolve_conv_mod
@ -109,6 +109,7 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_s_vect_type), intent(inout), optional :: s1, s2
! = local data
real(psb_spk_), allocatable, target :: aux(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
@ -154,8 +155,29 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
istop_ = psb_get_istop_default()
Endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info)
@ -202,7 +224,8 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -225,7 +248,7 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -299,7 +322,7 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -93,7 +93,7 @@
! where r is the (preconditioned, recursive
! estimate of) residual.
!
Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_s_linsolve_conv_mod
@ -109,6 +109,7 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_s_vect_type), intent(inout), optional :: s1, s2
! = Local data
real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:)
type(psb_s_vect_type) :: q, r, p, v, s, t, z, f
@ -156,13 +157,31 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
Endif
else
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b|| norm 2
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
! = if (.not.same_type_as(x,b)) then
! = write(0,*) 'Warning: different dynamic types for X and B '
! = end if
@ -217,7 +236,8 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
End If
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -234,7 +254,7 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(sone,r,szero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
@ -354,7 +374,7 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(omega,z,sone,x,desc_a,info)
call psb_geaxpby(sone,s,szero,r,desc_a,info)
call psb_geaxpby(-omega,t,sone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_,name,a_err='X/R update ')

@ -104,7 +104,7 @@
!
!
Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
& itmax,iter,err,itrace,irst,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_s_linsolve_conv_mod
@ -120,6 +120,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_s_vect_type), intent(inout), optional :: s1, s2
! = local data
real(psb_spk_), allocatable, target :: aux(:), gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
@ -172,8 +173,29 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
if (present(itmax)) then
itmax_ = itmax
@ -246,7 +268,8 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
rt0 => wwrk(10)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -284,7 +307,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',b%get_nrows()
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -388,7 +411,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-gamma1(j),rh(j),sone,rh(0),desc_a,info)
enddo
if (psb_check_conv(methdname,itx,x,rh(0),desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,rh(0),desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -104,7 +104,7 @@
!
!
subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
& itmax,iter,err,itrace,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_s_linsolve_conv_mod
@ -120,6 +120,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
real(psb_spk_), Optional, Intent(out) :: err,cond
type(psb_s_vect_type), intent(inout), optional :: s1, s2
! = Local data
type(psb_s_vect_type) :: v, w, d , q, r
real(psb_spk_) :: alpha, beta, delta, gamma, theta
@ -164,9 +165,29 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
@ -207,7 +228,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
& scratch=.true.,mold=x%v)
call psb_init_conv(methdname,istop_,itrace_,itmax_,&
& a,x,b,eps,desc_a,stopdat,info)
& a,x,b,eps,desc_a,stopdat,info,s1=s1,s2=s2)
itx = 0
restart: do
@ -226,7 +247,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) then
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) then
if (debug.and.(me==0)) write(0,*) name,' Exit on convergence from restart'
exit restart
end if
@ -282,7 +303,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) then
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) then
if (debug.and.(me==0)) write(0,*) name,' Exit on convergence from iteration'
exit restart
end if

@ -106,7 +106,7 @@
!
subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace, irst, istop)
& itmax,iter,err,itrace, irst, istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_s_linsolve_conv_mod
@ -124,6 +124,7 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
real(psb_spk_), Optional, Intent(out) :: err
type(psb_s_vect_type), intent(inout), optional :: s1, s2
! = local data
real(psb_spk_), allocatable :: alpha(:), h(:,:)
type(psb_s_vect_type), allocatable :: z(:), c(:), c_scale(:)
@ -167,22 +168,30 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b||, 2-norm
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
endif
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
& call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info)
@ -245,7 +254,8 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
nrst = -1
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
restart: do
if (itx>= itmax_) exit restart
h = szero
@ -268,7 +278,7 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
nrst = nrst + 1
@ -299,7 +309,7 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(sone, r, szero, r, desc_a, info)
call psb_geaxpby(-alpha(j), c_scale(j), sone, r, desc_a, info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (j >= irst) exit iteration

@ -80,7 +80,7 @@
! estimate of) residual
!
Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
& itmax,iter,err,itrace,irst,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod,only : psb_sprec_type
@ -97,11 +97,12 @@ Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
type(psb_s_vect_type), intent(inout), optional :: s1, s2
abstract interface
subroutine psb_skryl_vect(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop)
& desc_a,info,itmax,iter,err,itrace,istop,s1,s2)
import :: psb_ipk_, psb_spk_, psb_desc_type, &
& psb_sspmat_type, psb_sprec_type, psb_s_vect_type
type(psb_sspmat_type), intent(in) :: a
@ -114,9 +115,10 @@ Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_spk_), optional, intent(out) :: err
type(psb_s_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_skryl_vect
Subroutine psb_skryl_rest_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,irst,istop)
&itmax,iter,err, itrace,irst,istop,s1,s2)
import :: psb_ipk_, psb_spk_, psb_desc_type, &
& psb_sspmat_type, psb_sprec_type, psb_s_vect_type
Type(psb_sspmat_type), Intent(in) :: a
@ -129,9 +131,10 @@ Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_s_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_skryl_rest_vect
Subroutine psb_skryl_cond_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,istop,cond)
&itmax,iter,err, itrace,istop,cond,s1,s2)
import :: psb_ipk_, psb_spk_, psb_desc_type, &
& psb_sspmat_type, psb_sprec_type, psb_s_vect_type
Type(psb_sspmat_type), Intent(in) :: a
@ -144,6 +147,7 @@ Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err, cond
type(psb_s_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_skryl_cond_vect
end interface
@ -180,34 +184,34 @@ Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
select case(psb_toupper(method))
case('CG')
call psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond)
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond,s1=s1,s2=s2)
case('FCG')
call psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond)
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond,s1=s1,s2=s2)
case('GCR')
call psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('CGS')
call psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('BICG')
call psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('BICGSTAB')
call psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('RGMRES','GMRES')
call psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop)
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop,s1=s1,s2=s2)
case('BICGSTABL')
call psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop)
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop,s1=s1,s2=s2)
case default
if (me == 0) write(psb_err_unit,*) trim(name),&
& ': Warning: Unknown method ',method,&
& ', defaulting to BiCGSTAB'
call psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
end select
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)

@ -97,17 +97,20 @@
! iterations
! istop - integer(optional) Input: stopping criterion, or how
! to estimate the error.
! 1: err = |r|/(|a||x|+|b|); here the iteration is
! 1: err = |r|/(|a||x|+|b|); here
! the iteration is
! stopped when |r| <= eps * (|a||x|+|b|)
! 2: err = |r|/|b|; here the iteration is
! stopped when |r| <= eps * |b|
! 3: Same as 2 but with X and B scaled
! by s1 and s2
! where r is the (preconditioned, recursive
! estimate of) residual.
! irst - integer(optional) Input: restart parameter
!
subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
& itmax,iter,err,itrace,irst,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_s_linsolve_conv_mod
@ -123,6 +126,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
type(psb_s_vect_type), intent(inout), optional :: s1, s2
! = local data
real(psb_spk_), allocatable :: aux(:)
real(psb_spk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
@ -267,9 +271,20 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
select case(istop_)
case(psb_istop_ani_)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
if (present(s1)) then
call psb_gemlt(sone,s1,b,szero,v(1),desc_a,info)
bni = psb_geamax(v(1),desc_a,info)
else
bni = psb_geamax(b,desc_a,info)
end if
case(psb_istop_bn2_)
bn2 = psb_genrm2(b,desc_a,info)
if (present(s1)) then
call psb_gemlt(sone,s1,b,szero,v(1),desc_a,info)
bn2 = psb_genrm2(v(1),desc_a,info)
else
bn2 = psb_genrm2(b,desc_a,info)
end if
case(psb_istop_rn2_abs_)
! do nothing
case(psb_istop_rrn2_)
@ -281,6 +296,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
end if
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -322,7 +338,8 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_errpush(info,name)
goto 9999
end if
if (present(s1)) call psb_gemlt(s1,v(1),desc_a,info)
rs(1) = psb_genrm2(v(1),desc_a,info)
rs(2:) = szero
if (info /= psb_success_) then
@ -377,8 +394,14 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
inner: Do i=1,nl
itx = itx + 1
call prec%apply(v(i),w1,desc_a,info)
if (present(s2)) then
call psb_gediv(v(i),s2,w,desc_a,info)
call prec%apply(w,w1,desc_a,info)
else
call prec%apply(v(i),w1,desc_a,info)
end if
call psb_spmm(sone,a,w1,szero,w,desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,w,desc_a,info)
!
call mgs(i,h,v,w,rs,c,s,desc_a,info)
@ -390,10 +413,11 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
!
rst = rs
call psb_geaxpby(sone,x,szero,xt,desc_a,info)
call rebuildx(i,h,v,w,w1,xt,rst,c,s,prec,desc_a,info)
call rebuildx(i,h,v,w,w1,xt,rst,c,s,prec,desc_a,info,s2=s2)
call psb_geaxpby(sone,b,szero,w1,desc_a,info)
call psb_spmm(-sone,a,xt,sone,w1,desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,w,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@ -431,7 +455,8 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(sone,xt,szero,x,desc_a,info)
! = x = xt
case(psb_istop_bn2_, psb_istop_rn2_abs_,psb_istop_rrn2_)
call rebuildx(i,h,v,w,w1,x,rs,c,s,prec,desc_a,info) !
call rebuildx(i,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2=s2)
!
end select
@ -451,7 +476,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(sone,xt,szero,x,desc_a,info)! x = xt
case(psb_istop_bn2_, psb_istop_rn2_abs_,psb_istop_rrn2_)
call rebuildx(nl,h,v,w,w1,x,rs,c,s,prec,desc_a,info) !
call rebuildx(nl,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2=s2) !
end select
if (itx >= itmax_) then
@ -522,11 +547,12 @@ contains
! Rebuild solution X from the space V using the factor
! stored in R
!
subroutine rebuildx(n,h,v,w,w1,x,rs,c,s,prec,desc_a,info)
subroutine rebuildx(n,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2)
real(psb_spk_) :: c(:), s(:), rs(:), h(:,:)
type(psb_s_vect_type) :: v(:), w, w1, x
type(psb_desc_type) :: desc_a
class(psb_sprec_type) :: prec
type(psb_s_vect_type), intent(inout), optional :: s2
integer(psb_ipk_) :: info
integer(psb_ipk_) :: k,n
@ -538,12 +564,13 @@ contains
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Rebuild x-> RS:',rs(1:n)
call w1%zero()
call w%zero()
do k=1, n
call psb_geaxpby(rs(k),v(k),sone,w1,desc_a,info)
call psb_geaxpby(rs(k),v(k),sone,w,desc_a,info)
end do
call prec%apply(w1,w,desc_a,info)
call psb_geaxpby(sone,w,sone,x,desc_a,info)
if (present(s2)) call psb_gediv(s2,w,desc_a,info)
call prec%apply(w,w1,desc_a,info)
call psb_geaxpby(sone,w1,sone,x,desc_a,info)
end subroutine rebuildx
end subroutine psb_srgmres_vect

@ -120,8 +120,17 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
if (present(itmax)) then
itmax_ = itmax
else

@ -95,7 +95,7 @@
!
subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
& itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_z_linsolve_conv_mod
@ -111,6 +111,7 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(in) :: itmax, itrace, istop
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
type(psb_z_vect_type), intent(inout), optional :: s1, s2
! !$ local data
complex(psb_dpk_), allocatable, target :: aux(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
@ -160,19 +161,29 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
! istop_ = 2: ||r||/||b|| norm 2
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
info=psb_err_invalid_istop_
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
endif
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if(info /= psb_success_) then
@ -226,7 +237,8 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -252,7 +264,7 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
rho = zzero
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -306,7 +318,7 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,q,zone,r,desc_a,info)
call psb_geaxpby(-alpha,qt,zone,rt,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -96,7 +96,7 @@
!
!
subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
& itmax,iter,err,itrace,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_z_linsolve_conv_mod
@ -112,6 +112,8 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
type(psb_z_vect_type), intent(inout), optional :: s1, s2
! = Local data
complex(psb_dpk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
@ -159,8 +161,29 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
@ -224,7 +247,8 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
rho = zzero
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
&desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -268,7 +292,7 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(alpha,p,zone,x,desc_a,info)
call psb_geaxpby(-alpha,q,zone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -93,7 +93,7 @@
! estimate of) residual.
!
Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
& itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_z_linsolve_conv_mod
@ -109,6 +109,7 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_z_vect_type), intent(inout), optional :: s1, s2
! = local data
complex(psb_dpk_), allocatable, target :: aux(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
@ -154,8 +155,29 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
istop_ = psb_get_istop_default()
Endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info)
@ -202,7 +224,8 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -225,7 +248,7 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -299,7 +322,7 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -93,7 +93,7 @@
! where r is the (preconditioned, recursive
! estimate of) residual.
!
Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_z_linsolve_conv_mod
@ -109,6 +109,7 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_z_vect_type), intent(inout), optional :: s1, s2
! = Local data
complex(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
type(psb_z_vect_type) :: q, r, p, v, s, t, z, f
@ -156,13 +157,31 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
Endif
else
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b|| norm 2
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
! = if (.not.same_type_as(x,b)) then
! = write(0,*) 'Warning: different dynamic types for X and B '
! = end if
@ -217,7 +236,8 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
End If
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -234,7 +254,7 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(zone,r,zzero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
@ -354,7 +374,7 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(omega,z,zone,x,desc_a,info)
call psb_geaxpby(zone,s,zzero,r,desc_a,info)
call psb_geaxpby(-omega,t,zone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_,name,a_err='X/R update ')

@ -104,7 +104,7 @@
!
!
Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
& itmax,iter,err,itrace,irst,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_z_linsolve_conv_mod
@ -120,6 +120,7 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_z_vect_type), intent(inout), optional :: s1, s2
! = local data
complex(psb_dpk_), allocatable, target :: aux(:), gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
@ -172,8 +173,29 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
if (present(itmax)) then
itmax_ = itmax
@ -246,7 +268,8 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
rt0 => wwrk(10)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -284,7 +307,7 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',b%get_nrows()
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
@ -388,7 +411,7 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-gamma1(j),rh(j),zone,rh(0),desc_a,info)
enddo
if (psb_check_conv(methdname,itx,x,rh(0),desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,rh(0),desc_a,stopdat,info,s1=s1)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999

@ -104,7 +104,7 @@
!
!
subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
& itmax,iter,err,itrace,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_z_linsolve_conv_mod
@ -120,6 +120,7 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
real(psb_dpk_), Optional, Intent(out) :: err,cond
type(psb_z_vect_type), intent(inout), optional :: s1, s2
! = Local data
type(psb_z_vect_type) :: v, w, d , q, r
complex(psb_dpk_) :: alpha, beta, delta, gamma, theta
@ -164,9 +165,29 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
@ -207,7 +228,7 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
& scratch=.true.,mold=x%v)
call psb_init_conv(methdname,istop_,itrace_,itmax_,&
& a,x,b,eps,desc_a,stopdat,info)
& a,x,b,eps,desc_a,stopdat,info,s1=s1,s2=s2)
itx = 0
restart: do
@ -226,7 +247,7 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) then
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) then
if (debug.and.(me==0)) write(0,*) name,' Exit on convergence from restart'
exit restart
end if
@ -282,7 +303,7 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) then
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) then
if (debug.and.(me==0)) write(0,*) name,' Exit on convergence from iteration'
exit restart
end if

@ -106,7 +106,7 @@
!
subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace, irst, istop)
& itmax,iter,err,itrace, irst, istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_z_linsolve_conv_mod
@ -124,6 +124,7 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
real(psb_dpk_), Optional, Intent(out) :: err
type(psb_z_vect_type), intent(inout), optional :: s1, s2
! = local data
complex(psb_dpk_), allocatable :: alpha(:), h(:,:)
type(psb_z_vect_type), allocatable :: z(:), c(:), c_scale(:)
@ -167,22 +168,30 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b||, 2-norm
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
endif
end if
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
select case(istop_)
case(psb_istop_ani_,psb_istop_bn2_,&
& psb_istop_rn2_abs_, psb_istop_rrn2_)
! nothing needed
case default
! should never get here
info=psb_err_internal_error_
err=info
call psb_errpush(info,name,a_err="invalid istop_")
goto 9999
end select
call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info)
if (info == psb_success_)&
& call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info)
@ -245,7 +254,8 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
itx = 0
nrst = -1
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,desc_a,stopdat,info)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,x,b,eps,&
& desc_a,stopdat,info,s1=s1,s2=s2)
restart: do
if (itx>= itmax_) exit restart
h = zzero
@ -268,7 +278,7 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
nrst = nrst + 1
@ -299,7 +309,7 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(zone, r, zzero, r, desc_a, info)
call psb_geaxpby(-alpha(j), c_scale(j), zone, r, desc_a, info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info,s1=s1)) exit restart
if (j >= irst) exit iteration

@ -80,7 +80,7 @@
! estimate of) residual
!
Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
& itmax,iter,err,itrace,irst,istop,cond,s1,s2)
use psb_base_mod
use psb_prec_mod,only : psb_zprec_type
@ -97,11 +97,12 @@ Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
type(psb_z_vect_type), intent(inout), optional :: s1, s2
abstract interface
subroutine psb_zkryl_vect(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop)
& desc_a,info,itmax,iter,err,itrace,istop,s1,s2)
import :: psb_ipk_, psb_dpk_, psb_desc_type, &
& psb_zspmat_type, psb_zprec_type, psb_z_vect_type
type(psb_zspmat_type), intent(in) :: a
@ -114,9 +115,10 @@ Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
type(psb_z_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_zkryl_vect
Subroutine psb_zkryl_rest_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,irst,istop)
&itmax,iter,err, itrace,irst,istop,s1,s2)
import :: psb_ipk_, psb_dpk_, psb_desc_type, &
& psb_zspmat_type, psb_zprec_type, psb_z_vect_type
Type(psb_zspmat_type), Intent(in) :: a
@ -129,9 +131,10 @@ Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_z_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_zkryl_rest_vect
Subroutine psb_zkryl_cond_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,istop,cond)
&itmax,iter,err, itrace,istop,cond,s1,s2)
import :: psb_ipk_, psb_dpk_, psb_desc_type, &
& psb_zspmat_type, psb_zprec_type, psb_z_vect_type
Type(psb_zspmat_type), Intent(in) :: a
@ -144,6 +147,7 @@ Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err, cond
type(psb_z_vect_type), intent(inout), optional :: s1, s2
end subroutine psb_zkryl_cond_vect
end interface
@ -180,34 +184,34 @@ Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
select case(psb_toupper(method))
case('CG')
call psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond)
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond,s1=s1,s2=s2)
case('FCG')
call psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond)
&itmax,iter,err,itrace=itrace_,istop=istop,cond=cond,s1=s1,s2=s2)
case('GCR')
call psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('CGS')
call psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('BICG')
call psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('BICGSTAB')
call psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
case('RGMRES','GMRES')
call psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop)
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop,s1=s1,s2=s2)
case('BICGSTABL')
call psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop)
&itmax,iter,err,itrace=itrace_,irst=irst,istop=istop,s1=s1,s2=s2)
case default
if (me == 0) write(psb_err_unit,*) trim(name),&
& ': Warning: Unknown method ',method,&
& ', defaulting to BiCGSTAB'
call psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace=itrace_,istop=istop)
&itmax,iter,err,itrace=itrace_,istop=istop,s1=s1,s2=s2)
end select
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)

@ -97,17 +97,20 @@
! iterations
! istop - integer(optional) Input: stopping criterion, or how
! to estimate the error.
! 1: err = |r|/(|a||x|+|b|); here the iteration is
! 1: err = |r|/(|a||x|+|b|); here
! the iteration is
! stopped when |r| <= eps * (|a||x|+|b|)
! 2: err = |r|/|b|; here the iteration is
! stopped when |r| <= eps * |b|
! 3: Same as 2 but with X and B scaled
! by s1 and s2
! where r is the (preconditioned, recursive
! estimate of) residual.
! irst - integer(optional) Input: restart parameter
!
subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
& itmax,iter,err,itrace,irst,istop,s1,s2)
use psb_base_mod
use psb_prec_mod
use psb_z_linsolve_conv_mod
@ -123,6 +126,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
type(psb_z_vect_type), intent(inout), optional :: s1, s2
! = local data
complex(psb_dpk_), allocatable :: aux(:)
complex(psb_dpk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
@ -267,9 +271,20 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
select case(istop_)
case(psb_istop_ani_)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
if (present(s1)) then
call psb_gemlt(zone,s1,b,zzero,v(1),desc_a,info)
bni = psb_geamax(v(1),desc_a,info)
else
bni = psb_geamax(b,desc_a,info)
end if
case(psb_istop_bn2_)
bn2 = psb_genrm2(b,desc_a,info)
if (present(s1)) then
call psb_gemlt(zone,s1,b,zzero,v(1),desc_a,info)
bn2 = psb_genrm2(v(1),desc_a,info)
else
bn2 = psb_genrm2(b,desc_a,info)
end if
case(psb_istop_rn2_abs_)
! do nothing
case(psb_istop_rrn2_)
@ -281,6 +296,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
end if
call psb_spmm(-zone,a,x,zone,v(1),desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -322,7 +338,8 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_errpush(info,name)
goto 9999
end if
if (present(s1)) call psb_gemlt(s1,v(1),desc_a,info)
rs(1) = psb_genrm2(v(1),desc_a,info)
rs(2:) = zzero
if (info /= psb_success_) then
@ -377,8 +394,14 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
inner: Do i=1,nl
itx = itx + 1
call prec%apply(v(i),w1,desc_a,info)
if (present(s2)) then
call psb_gediv(v(i),s2,w,desc_a,info)
call prec%apply(w,w1,desc_a,info)
else
call prec%apply(v(i),w1,desc_a,info)
end if
call psb_spmm(zone,a,w1,zzero,w,desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,w,desc_a,info)
!
call mgs(i,h,v,w,rs,c,s,desc_a,info)
@ -390,10 +413,11 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
!
rst = rs
call psb_geaxpby(zone,x,zzero,xt,desc_a,info)
call rebuildx(i,h,v,w,w1,xt,rst,c,s,prec,desc_a,info)
call rebuildx(i,h,v,w,w1,xt,rst,c,s,prec,desc_a,info,s2=s2)
call psb_geaxpby(zone,b,zzero,w1,desc_a,info)
call psb_spmm(-zone,a,xt,zone,w1,desc_a,info,work=aux)
if (present(s1)) call psb_gemlt(s1,w,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@ -431,7 +455,8 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(zone,xt,zzero,x,desc_a,info)
! = x = xt
case(psb_istop_bn2_, psb_istop_rn2_abs_,psb_istop_rrn2_)
call rebuildx(i,h,v,w,w1,x,rs,c,s,prec,desc_a,info) !
call rebuildx(i,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2=s2)
!
end select
@ -451,7 +476,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(zone,xt,zzero,x,desc_a,info)! x = xt
case(psb_istop_bn2_, psb_istop_rn2_abs_,psb_istop_rrn2_)
call rebuildx(nl,h,v,w,w1,x,rs,c,s,prec,desc_a,info) !
call rebuildx(nl,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2=s2) !
end select
if (itx >= itmax_) then
@ -522,11 +547,12 @@ contains
! Rebuild solution X from the space V using the factor
! stored in R
!
subroutine rebuildx(n,h,v,w,w1,x,rs,c,s,prec,desc_a,info)
subroutine rebuildx(n,h,v,w,w1,x,rs,c,s,prec,desc_a,info,s2)
complex(psb_dpk_) :: c(:), s(:), rs(:), h(:,:)
type(psb_z_vect_type) :: v(:), w, w1, x
type(psb_desc_type) :: desc_a
class(psb_zprec_type) :: prec
type(psb_z_vect_type), intent(inout), optional :: s2
integer(psb_ipk_) :: info
integer(psb_ipk_) :: k,n
@ -538,12 +564,13 @@ contains
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Rebuild x-> RS:',rs(1:n)
call w1%zero()
call w%zero()
do k=1, n
call psb_geaxpby(rs(k),v(k),zone,w1,desc_a,info)
call psb_geaxpby(rs(k),v(k),zone,w,desc_a,info)
end do
call prec%apply(w1,w,desc_a,info)
call psb_geaxpby(zone,w,zone,x,desc_a,info)
if (present(s2)) call psb_gediv(s2,w,desc_a,info)
call prec%apply(w,w1,desc_a,info)
call psb_geaxpby(zone,w1,zone,x,desc_a,info)
end subroutine rebuildx
end subroutine psb_zrgmres_vect

@ -120,8 +120,17 @@ Subroutine psb_zrichardson_vect(a,prec,b,x,eps,desc_a,info,&
if (present(istop)) then
istop_ = istop
else
istop_ = 2
istop_ = psb_get_istop_default()
endif
if (.not.psb_is_valid_istop(istop_)) then
info=psb_err_invalid_istop_
err=info
call psb_errpush(info,name,i_err=(/istop_/))
goto 9999
end if
if (present(itmax)) then
itmax_ = itmax
else

@ -83,15 +83,18 @@ contains
stopdat%controls(psb_ik_itmax_) = itmax
select case(stopdat%controls(psb_ik_stopc_))
case (1)
case (psb_istop_ani_)
stopdat%values(psb_ik_ani_) = psb_spnrmi(a,desc_a,info)
if (info == psb_success_)&
& stopdat%values(psb_ik_bni_) = psb_geamax(b,desc_a,info)
case (2)
case (psb_istop_bn2_)
stopdat%values(psb_ik_bn2_) = psb_genrm2(b,desc_a,info)
case (3)
case (psb_istop_rn2_abs_)
! Do nothing
case (psb_istop_rrn2_)
call psb_geall(r,desc_a,info)
call psb_geaxpby(cone,b,czero,r,desc_a,info)
call psb_spmm(-cone,a,x,cone,r,desc_a,info)
@ -108,8 +111,8 @@ contains
end if
stopdat%values(psb_ik_eps_) = eps
stopdat%values(psb_ik_errnum_) = dzero
stopdat%values(psb_ik_errden_) = done
stopdat%values(psb_ik_errnum_) = szero
stopdat%values(psb_ik_errden_) = sone
if ((stopdat%controls(psb_ik_trace_) > 0).and. (me == 0))&
& call log_header(methdname)
@ -123,7 +126,6 @@ contains
end subroutine psb_c_init_conv
function psb_c_check_conv(methdname,it,x,r,desc_a,stopdat,info) result(res)
use psb_base_mod
implicit none
@ -149,19 +151,26 @@ contains
res = .false.
select case(stopdat%controls(psb_ik_stopc_))
case(1)
case(psb_istop_ani_)
stopdat%values(psb_ik_rni_) = psb_geamax(r,desc_a,info)
if (info == psb_success_) stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
if (info == psb_success_) &
& stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rni_)
stopdat%values(psb_ik_errden_) =&
& (stopdat%values(psb_ik_ani_)*stopdat%values(psb_ik_xni_)&
& +stopdat%values(psb_ik_bni_))
case(2)
case(psb_istop_bn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_bn2_)
case(3)
case (psb_istop_rn2_abs_)
stopdat%values(psb_ik_rn2_abs_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_abs_)
stopdat%values(psb_ik_errden_) = sone
case(psb_istop_rrn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_r0n2_)
@ -201,8 +210,8 @@ contains
end function psb_c_check_conv
subroutine psb_c_init_conv_vect(methdname,stopc,trace,itmax,a,x,b,eps,desc_a,stopdat,info)
subroutine psb_c_init_conv_vect(methdname,stopc,trace,itmax,&
& a,x,b,eps,desc_a,stopdat,info,s1,s2)
use psb_base_mod
implicit none
character(len=*), intent(in) :: methdname
@ -213,6 +222,7 @@ contains
type(psb_desc_type), intent(in) :: desc_a
type(psb_itconv_type) :: stopdat
integer(psb_ipk_), intent(out) :: info
type(psb_c_vect_type), optional :: s1, s2
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np, err_act
@ -236,15 +246,18 @@ contains
stopdat%controls(psb_ik_itmax_) = itmax
select case(stopdat%controls(psb_ik_stopc_))
case (1)
case (psb_istop_ani_)
stopdat%values(psb_ik_ani_) = psb_spnrmi(a,desc_a,info)
if (info == psb_success_)&
& stopdat%values(psb_ik_bni_) = psb_geamax(b,desc_a,info)
case (2)
case (psb_istop_bn2_)
stopdat%values(psb_ik_bn2_) = psb_genrm2(b,desc_a,info)
case (psb_istop_rn2_abs_)
! Do nothing
case (3)
case (psb_istop_rrn2_)
call psb_geasb(r,desc_a,info,scratch=.true.)
call psb_geaxpby(cone,b,czero,r,desc_a,info)
call psb_spmm(-cone,a,x,cone,r,desc_a,info)
@ -261,8 +274,8 @@ contains
end if
stopdat%values(psb_ik_eps_) = eps
stopdat%values(psb_ik_errnum_) = dzero
stopdat%values(psb_ik_errden_) = done
stopdat%values(psb_ik_errnum_) = szero
stopdat%values(psb_ik_errden_) = sone
if ((stopdat%controls(psb_ik_trace_) > 0).and. (me == 0))&
& call log_header(methdname)
@ -276,7 +289,8 @@ contains
end subroutine psb_c_init_conv_vect
function psb_c_check_conv_vect(methdname,it,x,r,desc_a,stopdat,info) result(res)
function psb_c_check_conv_vect(methdname,it,x,r,&
& desc_a,stopdat,info,s1,s2) result(res)
use psb_base_mod
implicit none
character(len=*), intent(in) :: methdname
@ -286,6 +300,7 @@ contains
type(psb_itconv_type) :: stopdat
logical :: res
integer(psb_ipk_), intent(out) :: info
type(psb_c_vect_type), optional :: s1, s2
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np, err_act
@ -303,19 +318,26 @@ contains
select case(stopdat%controls(psb_ik_stopc_))
case(1)
case(psb_istop_ani_)
stopdat%values(psb_ik_rni_) = psb_geamax(r,desc_a,info)
if (info == psb_success_) stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
if (info == psb_success_) &
& stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rni_)
stopdat%values(psb_ik_errden_) = &
& (stopdat%values(psb_ik_ani_)*stopdat%values(psb_ik_xni_)&
& +stopdat%values(psb_ik_bni_))
case(2)
case(psb_istop_bn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_bn2_)
case(3)
case (psb_istop_rn2_abs_)
stopdat%values(psb_ik_rn2_abs_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_abs_)
stopdat%values(psb_ik_errden_) = sone
case(psb_istop_rrn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_r0n2_)

@ -0,0 +1,81 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
! File: psb_linsolve_mod.f90
! Interfaces for linear solvers.
!
Module psb_c_linsolve_mod
use psb_const_mod
public
interface psb_krylov
Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond,s1,s2)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_cspmat_type, &
& psb_spk_, psb_c_vect_type
use psb_prec_mod, only : psb_cprec_type
character(len=*) :: method
Type(psb_cspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_cprec_type), intent(inout) :: prec
type(psb_c_vect_type), Intent(inout) :: b
type(psb_c_vect_type), Intent(inout) :: x
Real(psb_spk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
type(psb_c_vect_type), optional :: s1,s2
end Subroutine psb_ckrylov_vect
end interface
interface psb_richardson
Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_cspmat_type, &
& psb_spk_, psb_c_vect_type
use psb_prec_mod, only : psb_cprec_type
Type(psb_cspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_cprec_type), intent(inout) :: prec
type(psb_c_vect_type), Intent(inout) :: b
type(psb_c_vect_type), Intent(inout) :: x
Real(psb_spk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
end Subroutine psb_crichardson_vect
end interface
end module psb_c_linsolve_mod

@ -83,15 +83,18 @@ contains
stopdat%controls(psb_ik_itmax_) = itmax
select case(stopdat%controls(psb_ik_stopc_))
case (1)
case (psb_istop_ani_)
stopdat%values(psb_ik_ani_) = psb_spnrmi(a,desc_a,info)
if (info == psb_success_)&
& stopdat%values(psb_ik_bni_) = psb_geamax(b,desc_a,info)
case (2)
case (psb_istop_bn2_)
stopdat%values(psb_ik_bn2_) = psb_genrm2(b,desc_a,info)
case (3)
case (psb_istop_rn2_abs_)
! Do nothing
case (psb_istop_rrn2_)
call psb_geall(r,desc_a,info)
call psb_geaxpby(done,b,dzero,r,desc_a,info)
call psb_spmm(-done,a,x,done,r,desc_a,info)
@ -123,7 +126,6 @@ contains
end subroutine psb_d_init_conv
function psb_d_check_conv(methdname,it,x,r,desc_a,stopdat,info) result(res)
use psb_base_mod
implicit none
@ -149,19 +151,26 @@ contains
res = .false.
select case(stopdat%controls(psb_ik_stopc_))
case(1)
case(psb_istop_ani_)
stopdat%values(psb_ik_rni_) = psb_geamax(r,desc_a,info)
if (info == psb_success_) stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
if (info == psb_success_) &
& stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rni_)
stopdat%values(psb_ik_errden_) =&
& (stopdat%values(psb_ik_ani_)*stopdat%values(psb_ik_xni_)&
& +stopdat%values(psb_ik_bni_))
case(2)
case(psb_istop_bn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_bn2_)
case(3)
case (psb_istop_rn2_abs_)
stopdat%values(psb_ik_rn2_abs_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_abs_)
stopdat%values(psb_ik_errden_) = done
case(psb_istop_rrn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_r0n2_)
@ -201,8 +210,8 @@ contains
end function psb_d_check_conv
subroutine psb_d_init_conv_vect(methdname,stopc,trace,itmax,a,x,b,eps,desc_a,stopdat,info)
subroutine psb_d_init_conv_vect(methdname,stopc,trace,itmax,&
& a,x,b,eps,desc_a,stopdat,info,s1,s2)
use psb_base_mod
implicit none
character(len=*), intent(in) :: methdname
@ -213,6 +222,7 @@ contains
type(psb_desc_type), intent(in) :: desc_a
type(psb_itconv_type) :: stopdat
integer(psb_ipk_), intent(out) :: info
type(psb_d_vect_type), optional :: s1, s2
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np, err_act
@ -236,15 +246,18 @@ contains
stopdat%controls(psb_ik_itmax_) = itmax
select case(stopdat%controls(psb_ik_stopc_))
case (1)
case (psb_istop_ani_)
stopdat%values(psb_ik_ani_) = psb_spnrmi(a,desc_a,info)
if (info == psb_success_)&
& stopdat%values(psb_ik_bni_) = psb_geamax(b,desc_a,info)
case (2)
case (psb_istop_bn2_)
stopdat%values(psb_ik_bn2_) = psb_genrm2(b,desc_a,info)
case (psb_istop_rn2_abs_)
! Do nothing
case (3)
case (psb_istop_rrn2_)
call psb_geasb(r,desc_a,info,scratch=.true.)
call psb_geaxpby(done,b,dzero,r,desc_a,info)
call psb_spmm(-done,a,x,done,r,desc_a,info)
@ -276,7 +289,8 @@ contains
end subroutine psb_d_init_conv_vect
function psb_d_check_conv_vect(methdname,it,x,r,desc_a,stopdat,info) result(res)
function psb_d_check_conv_vect(methdname,it,x,r,&
& desc_a,stopdat,info,s1,s2) result(res)
use psb_base_mod
implicit none
character(len=*), intent(in) :: methdname
@ -286,6 +300,7 @@ contains
type(psb_itconv_type) :: stopdat
logical :: res
integer(psb_ipk_), intent(out) :: info
type(psb_d_vect_type), optional :: s1, s2
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np, err_act
@ -303,19 +318,26 @@ contains
select case(stopdat%controls(psb_ik_stopc_))
case(1)
case(psb_istop_ani_)
stopdat%values(psb_ik_rni_) = psb_geamax(r,desc_a,info)
if (info == psb_success_) stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
if (info == psb_success_) &
& stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rni_)
stopdat%values(psb_ik_errden_) = &
& (stopdat%values(psb_ik_ani_)*stopdat%values(psb_ik_xni_)&
& +stopdat%values(psb_ik_bni_))
case(2)
case(psb_istop_bn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_bn2_)
case(3)
case (psb_istop_rn2_abs_)
stopdat%values(psb_ik_rn2_abs_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_abs_)
stopdat%values(psb_ik_errden_) = done
case(psb_istop_rrn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_r0n2_)

@ -0,0 +1,81 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
! File: psb_linsolve_mod.f90
! Interfaces for linear solvers.
!
Module psb_d_linsolve_mod
use psb_const_mod
public
interface psb_krylov
Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond,s1,s2)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_dspmat_type, &
& psb_dpk_, psb_d_vect_type
use psb_prec_mod, only : psb_dprec_type
character(len=*) :: method
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_dprec_type), intent(inout) :: prec
type(psb_d_vect_type), Intent(inout) :: b
type(psb_d_vect_type), Intent(inout) :: x
Real(psb_dpk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
type(psb_d_vect_type), optional :: s1,s2
end Subroutine psb_dkrylov_vect
end interface
interface psb_richardson
Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_dspmat_type, &
& psb_dpk_, psb_d_vect_type
use psb_prec_mod, only : psb_dprec_type
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_dprec_type), intent(inout) :: prec
type(psb_d_vect_type), Intent(inout) :: b
type(psb_d_vect_type), Intent(inout) :: x
Real(psb_dpk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
end Subroutine psb_drichardson_vect
end interface
end module psb_d_linsolve_mod

@ -36,179 +36,9 @@
Module psb_linsolve_mod
use psb_const_mod
public
interface psb_krylov
Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_sspmat_type, &
& psb_spk_, psb_s_vect_type
use psb_prec_mod, only : psb_sprec_type
character(len=*) :: method
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_sprec_type), intent(inout) :: prec
type(psb_s_vect_type), Intent(inout) :: b
type(psb_s_vect_type), Intent(inout) :: x
Real(psb_spk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
end Subroutine psb_skrylov_vect
Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_cspmat_type, &
& psb_spk_, psb_c_vect_type
use psb_prec_mod, only : psb_cprec_type
character(len=*) :: method
Type(psb_cspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_cprec_type), intent(inout) :: prec
type(psb_c_vect_type), Intent(inout) :: b
type(psb_c_vect_type), Intent(inout) :: x
Real(psb_spk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
end Subroutine psb_ckrylov_vect
Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_dspmat_type, &
& psb_dpk_, psb_d_vect_type
use psb_prec_mod, only : psb_dprec_type
character(len=*) :: method
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_dprec_type), intent(inout) :: prec
type(psb_d_vect_type), Intent(inout) :: b
type(psb_d_vect_type), Intent(inout) :: x
Real(psb_dpk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
end Subroutine psb_dkrylov_vect
Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_zspmat_type, &
& psb_dpk_, psb_z_vect_type
use psb_prec_mod, only : psb_zprec_type
character(len=*) :: method
Type(psb_zspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_zprec_type), intent(inout) :: prec
type(psb_z_vect_type), Intent(inout) :: b
type(psb_z_vect_type), Intent(inout) :: x
Real(psb_dpk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
end Subroutine psb_zkrylov_vect
end interface
interface psb_richardson
Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_sspmat_type, &
& psb_spk_, psb_s_vect_type
use psb_prec_mod, only : psb_sprec_type
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_sprec_type), intent(inout) :: prec
type(psb_s_vect_type), Intent(inout) :: b
type(psb_s_vect_type), Intent(inout) :: x
Real(psb_spk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
end Subroutine psb_srichardson_vect
Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_cspmat_type, &
& psb_spk_, psb_c_vect_type
use psb_prec_mod, only : psb_cprec_type
Type(psb_cspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_cprec_type), intent(inout) :: prec
type(psb_c_vect_type), Intent(inout) :: b
type(psb_c_vect_type), Intent(inout) :: x
Real(psb_spk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
end Subroutine psb_crichardson_vect
Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_dspmat_type, &
& psb_dpk_, psb_d_vect_type
use psb_prec_mod, only : psb_dprec_type
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_dprec_type), intent(inout) :: prec
type(psb_d_vect_type), Intent(inout) :: b
type(psb_d_vect_type), Intent(inout) :: x
Real(psb_dpk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
end Subroutine psb_drichardson_vect
Subroutine psb_zrichardson_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_zspmat_type, &
& psb_dpk_, psb_z_vect_type
use psb_prec_mod, only : psb_zprec_type
Type(psb_zspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_zprec_type), intent(inout) :: prec
type(psb_z_vect_type), Intent(inout) :: b
type(psb_z_vect_type), Intent(inout) :: x
Real(psb_dpk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
end Subroutine psb_zrichardson_vect
end interface
use psb_s_linsolve_mod
use psb_d_linsolve_mod
use psb_c_linsolve_mod
use psb_z_linsolve_mod
end module psb_linsolve_mod

@ -83,15 +83,18 @@ contains
stopdat%controls(psb_ik_itmax_) = itmax
select case(stopdat%controls(psb_ik_stopc_))
case (1)
case (psb_istop_ani_)
stopdat%values(psb_ik_ani_) = psb_spnrmi(a,desc_a,info)
if (info == psb_success_)&
& stopdat%values(psb_ik_bni_) = psb_geamax(b,desc_a,info)
case (2)
case (psb_istop_bn2_)
stopdat%values(psb_ik_bn2_) = psb_genrm2(b,desc_a,info)
case (3)
case (psb_istop_rn2_abs_)
! Do nothing
case (psb_istop_rrn2_)
call psb_geall(r,desc_a,info)
call psb_geaxpby(sone,b,szero,r,desc_a,info)
call psb_spmm(-sone,a,x,sone,r,desc_a,info)
@ -108,8 +111,8 @@ contains
end if
stopdat%values(psb_ik_eps_) = eps
stopdat%values(psb_ik_errnum_) = dzero
stopdat%values(psb_ik_errden_) = done
stopdat%values(psb_ik_errnum_) = szero
stopdat%values(psb_ik_errden_) = sone
if ((stopdat%controls(psb_ik_trace_) > 0).and. (me == 0))&
& call log_header(methdname)
@ -123,7 +126,6 @@ contains
end subroutine psb_s_init_conv
function psb_s_check_conv(methdname,it,x,r,desc_a,stopdat,info) result(res)
use psb_base_mod
implicit none
@ -149,19 +151,26 @@ contains
res = .false.
select case(stopdat%controls(psb_ik_stopc_))
case(1)
case(psb_istop_ani_)
stopdat%values(psb_ik_rni_) = psb_geamax(r,desc_a,info)
if (info == psb_success_) stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
if (info == psb_success_) &
& stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rni_)
stopdat%values(psb_ik_errden_) =&
& (stopdat%values(psb_ik_ani_)*stopdat%values(psb_ik_xni_)&
& +stopdat%values(psb_ik_bni_))
case(2)
case(psb_istop_bn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_bn2_)
case(3)
case (psb_istop_rn2_abs_)
stopdat%values(psb_ik_rn2_abs_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_abs_)
stopdat%values(psb_ik_errden_) = sone
case(psb_istop_rrn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_r0n2_)
@ -201,8 +210,8 @@ contains
end function psb_s_check_conv
subroutine psb_s_init_conv_vect(methdname,stopc,trace,itmax,a,x,b,eps,desc_a,stopdat,info)
subroutine psb_s_init_conv_vect(methdname,stopc,trace,itmax,&
& a,x,b,eps,desc_a,stopdat,info,s1,s2)
use psb_base_mod
implicit none
character(len=*), intent(in) :: methdname
@ -213,6 +222,7 @@ contains
type(psb_desc_type), intent(in) :: desc_a
type(psb_itconv_type) :: stopdat
integer(psb_ipk_), intent(out) :: info
type(psb_s_vect_type), optional :: s1, s2
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np, err_act
@ -236,15 +246,18 @@ contains
stopdat%controls(psb_ik_itmax_) = itmax
select case(stopdat%controls(psb_ik_stopc_))
case (1)
case (psb_istop_ani_)
stopdat%values(psb_ik_ani_) = psb_spnrmi(a,desc_a,info)
if (info == psb_success_)&
& stopdat%values(psb_ik_bni_) = psb_geamax(b,desc_a,info)
case (2)
case (psb_istop_bn2_)
stopdat%values(psb_ik_bn2_) = psb_genrm2(b,desc_a,info)
case (psb_istop_rn2_abs_)
! Do nothing
case (3)
case (psb_istop_rrn2_)
call psb_geasb(r,desc_a,info,scratch=.true.)
call psb_geaxpby(sone,b,szero,r,desc_a,info)
call psb_spmm(-sone,a,x,sone,r,desc_a,info)
@ -261,8 +274,8 @@ contains
end if
stopdat%values(psb_ik_eps_) = eps
stopdat%values(psb_ik_errnum_) = dzero
stopdat%values(psb_ik_errden_) = done
stopdat%values(psb_ik_errnum_) = szero
stopdat%values(psb_ik_errden_) = sone
if ((stopdat%controls(psb_ik_trace_) > 0).and. (me == 0))&
& call log_header(methdname)
@ -276,7 +289,8 @@ contains
end subroutine psb_s_init_conv_vect
function psb_s_check_conv_vect(methdname,it,x,r,desc_a,stopdat,info) result(res)
function psb_s_check_conv_vect(methdname,it,x,r,&
& desc_a,stopdat,info,s1,s2) result(res)
use psb_base_mod
implicit none
character(len=*), intent(in) :: methdname
@ -286,6 +300,7 @@ contains
type(psb_itconv_type) :: stopdat
logical :: res
integer(psb_ipk_), intent(out) :: info
type(psb_s_vect_type), optional :: s1, s2
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np, err_act
@ -303,19 +318,26 @@ contains
select case(stopdat%controls(psb_ik_stopc_))
case(1)
case(psb_istop_ani_)
stopdat%values(psb_ik_rni_) = psb_geamax(r,desc_a,info)
if (info == psb_success_) stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
if (info == psb_success_) &
& stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rni_)
stopdat%values(psb_ik_errden_) = &
& (stopdat%values(psb_ik_ani_)*stopdat%values(psb_ik_xni_)&
& +stopdat%values(psb_ik_bni_))
case(2)
case(psb_istop_bn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_bn2_)
case(3)
case (psb_istop_rn2_abs_)
stopdat%values(psb_ik_rn2_abs_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_abs_)
stopdat%values(psb_ik_errden_) = sone
case(psb_istop_rrn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_r0n2_)

@ -0,0 +1,81 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
! File: psb_linsolve_mod.f90
! Interfaces for linear solvers.
!
Module psb_s_linsolve_mod
use psb_const_mod
public
interface psb_krylov
Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond,s1,s2)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_sspmat_type, &
& psb_spk_, psb_s_vect_type
use psb_prec_mod, only : psb_sprec_type
character(len=*) :: method
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_sprec_type), intent(inout) :: prec
type(psb_s_vect_type), Intent(inout) :: b
type(psb_s_vect_type), Intent(inout) :: x
Real(psb_spk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
type(psb_s_vect_type), optional :: s1,s2
end Subroutine psb_skrylov_vect
end interface
interface psb_richardson
Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_sspmat_type, &
& psb_spk_, psb_s_vect_type
use psb_prec_mod, only : psb_sprec_type
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_sprec_type), intent(inout) :: prec
type(psb_s_vect_type), Intent(inout) :: b
type(psb_s_vect_type), Intent(inout) :: x
Real(psb_spk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
end Subroutine psb_srichardson_vect
end interface
end module psb_s_linsolve_mod

@ -83,15 +83,18 @@ contains
stopdat%controls(psb_ik_itmax_) = itmax
select case(stopdat%controls(psb_ik_stopc_))
case (1)
case (psb_istop_ani_)
stopdat%values(psb_ik_ani_) = psb_spnrmi(a,desc_a,info)
if (info == psb_success_)&
& stopdat%values(psb_ik_bni_) = psb_geamax(b,desc_a,info)
case (2)
case (psb_istop_bn2_)
stopdat%values(psb_ik_bn2_) = psb_genrm2(b,desc_a,info)
case (3)
case (psb_istop_rn2_abs_)
! Do nothing
case (psb_istop_rrn2_)
call psb_geall(r,desc_a,info)
call psb_geaxpby(zone,b,zzero,r,desc_a,info)
call psb_spmm(-zone,a,x,zone,r,desc_a,info)
@ -123,7 +126,6 @@ contains
end subroutine psb_z_init_conv
function psb_z_check_conv(methdname,it,x,r,desc_a,stopdat,info) result(res)
use psb_base_mod
implicit none
@ -149,19 +151,26 @@ contains
res = .false.
select case(stopdat%controls(psb_ik_stopc_))
case(1)
case(psb_istop_ani_)
stopdat%values(psb_ik_rni_) = psb_geamax(r,desc_a,info)
if (info == psb_success_) stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
if (info == psb_success_) &
& stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rni_)
stopdat%values(psb_ik_errden_) =&
& (stopdat%values(psb_ik_ani_)*stopdat%values(psb_ik_xni_)&
& +stopdat%values(psb_ik_bni_))
case(2)
case(psb_istop_bn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_bn2_)
case(3)
case (psb_istop_rn2_abs_)
stopdat%values(psb_ik_rn2_abs_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_abs_)
stopdat%values(psb_ik_errden_) = done
case(psb_istop_rrn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_r0n2_)
@ -201,8 +210,8 @@ contains
end function psb_z_check_conv
subroutine psb_z_init_conv_vect(methdname,stopc,trace,itmax,a,x,b,eps,desc_a,stopdat,info)
subroutine psb_z_init_conv_vect(methdname,stopc,trace,itmax,&
& a,x,b,eps,desc_a,stopdat,info,s1,s2)
use psb_base_mod
implicit none
character(len=*), intent(in) :: methdname
@ -213,6 +222,7 @@ contains
type(psb_desc_type), intent(in) :: desc_a
type(psb_itconv_type) :: stopdat
integer(psb_ipk_), intent(out) :: info
type(psb_z_vect_type), optional :: s1, s2
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np, err_act
@ -236,15 +246,18 @@ contains
stopdat%controls(psb_ik_itmax_) = itmax
select case(stopdat%controls(psb_ik_stopc_))
case (1)
case (psb_istop_ani_)
stopdat%values(psb_ik_ani_) = psb_spnrmi(a,desc_a,info)
if (info == psb_success_)&
& stopdat%values(psb_ik_bni_) = psb_geamax(b,desc_a,info)
case (2)
case (psb_istop_bn2_)
stopdat%values(psb_ik_bn2_) = psb_genrm2(b,desc_a,info)
case (psb_istop_rn2_abs_)
! Do nothing
case (3)
case (psb_istop_rrn2_)
call psb_geasb(r,desc_a,info,scratch=.true.)
call psb_geaxpby(zone,b,zzero,r,desc_a,info)
call psb_spmm(-zone,a,x,zone,r,desc_a,info)
@ -276,7 +289,8 @@ contains
end subroutine psb_z_init_conv_vect
function psb_z_check_conv_vect(methdname,it,x,r,desc_a,stopdat,info) result(res)
function psb_z_check_conv_vect(methdname,it,x,r,&
& desc_a,stopdat,info,s1,s2) result(res)
use psb_base_mod
implicit none
character(len=*), intent(in) :: methdname
@ -286,6 +300,7 @@ contains
type(psb_itconv_type) :: stopdat
logical :: res
integer(psb_ipk_), intent(out) :: info
type(psb_z_vect_type), optional :: s1, s2
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np, err_act
@ -303,19 +318,26 @@ contains
select case(stopdat%controls(psb_ik_stopc_))
case(1)
case(psb_istop_ani_)
stopdat%values(psb_ik_rni_) = psb_geamax(r,desc_a,info)
if (info == psb_success_) stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
if (info == psb_success_) &
& stopdat%values(psb_ik_xni_) = psb_geamax(x,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rni_)
stopdat%values(psb_ik_errden_) = &
& (stopdat%values(psb_ik_ani_)*stopdat%values(psb_ik_xni_)&
& +stopdat%values(psb_ik_bni_))
case(2)
case(psb_istop_bn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_bn2_)
case(3)
case (psb_istop_rn2_abs_)
stopdat%values(psb_ik_rn2_abs_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_abs_)
stopdat%values(psb_ik_errden_) = done
case(psb_istop_rrn2_)
stopdat%values(psb_ik_rn2_) = psb_genrm2(r,desc_a,info)
stopdat%values(psb_ik_errnum_) = stopdat%values(psb_ik_rn2_)
stopdat%values(psb_ik_errden_) = stopdat%values(psb_ik_r0n2_)

@ -0,0 +1,81 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
! File: psb_linsolve_mod.f90
! Interfaces for linear solvers.
!
Module psb_z_linsolve_mod
use psb_const_mod
public
interface psb_krylov
Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond,s1,s2)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_zspmat_type, &
& psb_dpk_, psb_z_vect_type
use psb_prec_mod, only : psb_zprec_type
character(len=*) :: method
Type(psb_zspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_zprec_type), intent(inout) :: prec
type(psb_z_vect_type), Intent(inout) :: b
type(psb_z_vect_type), Intent(inout) :: x
Real(psb_dpk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
type(psb_z_vect_type), optional :: s1,s2
end Subroutine psb_zkrylov_vect
end interface
interface psb_richardson
Subroutine psb_zrichardson_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_ipk_, psb_desc_type, psb_zspmat_type, &
& psb_dpk_, psb_z_vect_type
use psb_prec_mod, only : psb_zprec_type
Type(psb_zspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_zprec_type), intent(inout) :: prec
type(psb_z_vect_type), Intent(inout) :: b
type(psb_z_vect_type), Intent(inout) :: x
Real(psb_dpk_), Intent(in) :: eps
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
end Subroutine psb_zrichardson_vect
end interface
end module psb_z_linsolve_mod

@ -8,10 +8,12 @@ MODDIR=../modules
HERE=.
BASEOBJS= psb_blockpart_mod.o psb_metispart_mod.o psb_partidx_mod.o \
psb_hbio_mod.o psb_mmio_mod.o psb_mat_dist_mod.o \
psb_s_mat_dist_mod.o psb_d_mat_dist_mod.o psb_c_mat_dist_mod.o psb_z_mat_dist_mod.o \
psb_renum_mod.o psb_gps_mod.o \
psb_s_renum_mod.o psb_d_renum_mod.o psb_c_renum_mod.o psb_z_renum_mod.o
psb_hbio_mod.o psb_mmio_mod.o \
psb_i_mmio_mod.o psb_s_mmio_mod.o psb_d_mmio_mod.o psb_c_mmio_mod.o psb_z_mmio_mod.o \
psb_mat_dist_mod.o \
psb_s_mat_dist_mod.o psb_d_mat_dist_mod.o psb_c_mat_dist_mod.o psb_z_mat_dist_mod.o \
psb_renum_mod.o psb_gps_mod.o \
psb_s_renum_mod.o psb_d_renum_mod.o psb_c_renum_mod.o psb_z_renum_mod.o
IMPLOBJS= psb_s_hbio_impl.o psb_d_hbio_impl.o \
psb_c_hbio_impl.o psb_z_hbio_impl.o \
psb_s_mmio_impl.o psb_d_mmio_impl.o \
@ -46,7 +48,7 @@ psb_util_mod.o: $(BASEOBJS)
psb_metispart_mod.o: psb_metis_int.o
psb_mat_dist_mod.o: psb_s_mat_dist_mod.o psb_d_mat_dist_mod.o psb_c_mat_dist_mod.o psb_z_mat_dist_mod.o
psb_renum_mod.o: psb_s_renum_mod.o psb_d_renum_mod.o psb_c_renum_mod.o psb_z_renum_mod.o
psb_mmio_mod.o: psb_i_mmio_mod.o psb_s_mmio_mod.o psb_d_mmio_mod.o psb_c_mmio_mod.o psb_z_mmio_mod.o
$(IMPLOBJS): $(BASEOBJS)
veryclean: clean

@ -0,0 +1,155 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
module psb_c_mmio_mod
use psb_base_mod, only : psb_ipk_, psb_lpk_, psb_spk_,&
& psb_c_vect_type, psb_cspmat_type, psb_lcspmat_type
!public mm_mat_read, mm_mat_write, mm_array_read, mm_array_write
interface mm_array_read
subroutine mm_cvet_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
complex(psb_spk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvet_read
subroutine mm_cvet2_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
complex(psb_spk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvet2_read
subroutine mm_cvect_read(b, info, iunit, filename)
import :: psb_ipk_,psb_c_vect_type
implicit none
type(psb_c_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvect_read
end interface mm_array_read
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_read
procedure mm_cvet_read, mm_cvet2_read
end interface
#endif
#endif
interface mm_array_write
subroutine mm_cvet2_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
complex(psb_spk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvet2_write
subroutine mm_cvet1_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
complex(psb_spk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvet1_write
subroutine mm_cvect_write(b, header, info, iunit, filename)
import :: psb_ipk_, psb_c_vect_type
implicit none
type(psb_c_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvect_write
end interface
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_write
procedure mm_cvet1_write, mm_cvet2_write
end interface
#endif
interface mm_mat_read
subroutine cmm_mat_read(a, info, iunit, filename)
import :: psb_cspmat_type, psb_ipk_
implicit none
type(psb_cspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine cmm_mat_read
subroutine lcmm_mat_read(a, info, iunit, filename)
import :: psb_lcspmat_type, psb_ipk_
implicit none
type(psb_lcspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lcmm_mat_read
end interface
interface mm_mat_write
subroutine cmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_cspmat_type, psb_ipk_
implicit none
type(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine cmm_mat_write
subroutine lcmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_lcspmat_type, psb_ipk_
implicit none
type(psb_lcspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lcmm_mat_write
end interface
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
public mm_vet_read, mm_vet_write
#endif
#endif
end module psb_c_mmio_mod

@ -0,0 +1,155 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
module psb_d_mmio_mod
use psb_base_mod, only : psb_ipk_, psb_lpk_, psb_dpk_,&
& psb_d_vect_type, psb_dspmat_type, psb_ldspmat_type
!public mm_mat_read, mm_mat_write, mm_array_read, mm_array_write
interface mm_array_read
subroutine mm_dvet_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
real(psb_dpk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvet_read
subroutine mm_dvet2_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
real(psb_dpk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvet2_read
subroutine mm_dvect_read(b, info, iunit, filename)
import :: psb_ipk_,psb_d_vect_type
implicit none
type(psb_d_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvect_read
end interface mm_array_read
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_read
procedure mm_dvet_read, mm_dvet2_read
end interface
#endif
#endif
interface mm_array_write
subroutine mm_dvet2_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
real(psb_dpk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvet2_write
subroutine mm_dvet1_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
real(psb_dpk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvet1_write
subroutine mm_dvect_write(b, header, info, iunit, filename)
import :: psb_ipk_, psb_d_vect_type
implicit none
type(psb_d_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvect_write
end interface
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_write
procedure mm_dvet1_write, mm_dvet2_write
end interface
#endif
interface mm_mat_read
subroutine dmm_mat_read(a, info, iunit, filename)
import :: psb_dspmat_type, psb_ipk_
implicit none
type(psb_dspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine dmm_mat_read
subroutine ldmm_mat_read(a, info, iunit, filename)
import :: psb_ldspmat_type, psb_ipk_
implicit none
type(psb_ldspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine ldmm_mat_read
end interface
interface mm_mat_write
subroutine dmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_dspmat_type, psb_ipk_
implicit none
type(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine dmm_mat_write
subroutine ldmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_ldspmat_type, psb_ipk_
implicit none
type(psb_ldspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine ldmm_mat_write
end interface
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
public mm_vet_read, mm_vet_write
#endif
#endif
end module psb_d_mmio_mod

@ -0,0 +1,160 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
module psb_i_mmio_mod
use psb_base_mod, only : psb_ipk_, psb_lpk_,&
& psb_i_vect_type, psb_l_vect_type
!public mm_mat_read, mm_mat_write, mm_array_read, mm_array_write
interface mm_array_read
subroutine mm_ivet_read(b, info, iunit, filename)
import :: psb_ipk_
implicit none
integer(psb_ipk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet_read
subroutine mm_ivet2_read(b, info, iunit, filename)
import :: psb_ipk_
implicit none
integer(psb_ipk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet2_read
subroutine mm_ivect_read(b, info, iunit, filename)
import :: psb_ipk_, psb_i_vect_type
implicit none
type(psb_i_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivect_read
subroutine mm_lvect_read(b, info, iunit, filename)
import :: psb_ipk_, psb_l_vect_type
implicit none
type(psb_l_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvect_read
#if defined(PSB_IPK4) && defined(PSB_LPK8)
subroutine mm_lvet_read(b, info, iunit, filename)
import :: psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvet_read
subroutine mm_lvet2_read(b, info, iunit, filename)
import :: psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvet2_read
end interface mm_array_read
#endif
interface mm_array_write
subroutine mm_ivet2_write(b, header, info, iunit, filename)
import :: psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet2_write
subroutine mm_ivet1_write(b, header, info, iunit, filename)
import :: psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet1_write
#if defined(PSB_IPK4) && defined(PSB_LPK8)
subroutine mm_lvet2_write(b, header, info, iunit, filename)
import :: psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvet2_write
subroutine mm_lvet1_write(b, header, info, iunit, filename)
import :: psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvet1_write
subroutine mm_ivect_write(b, header, info, iunit, filename)
import :: psb_ipk_,psb_i_vect_type
implicit none
type(psb_i_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivect_write
subroutine mm_lvect_write(b, header, info, iunit, filename)
import :: psb_ipk_,psb_l_vect_type
implicit none
type(psb_l_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvect_write
end interface mm_array_write
#endif
interface mm_vet_write
procedure mm_ivet1_write, mm_ivet2_write
end interface
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
public mm_vet_read, mm_vet_write
#endif
#endif
end module psb_i_mmio_mod

@ -30,497 +30,9 @@
!
!
module psb_mmio_mod
use psb_base_mod, only : psb_ipk_, psb_lpk_, psb_spk_, psb_dpk_,&
& psb_s_vect_type, psb_d_vect_type, psb_i_vect_type, psb_l_vect_type,&
& psb_c_vect_type, psb_z_vect_type, &
& psb_sspmat_type, psb_cspmat_type, &
& psb_dspmat_type, psb_zspmat_type, &
& psb_lsspmat_type, psb_lcspmat_type, &
& psb_ldspmat_type, psb_lzspmat_type
public mm_mat_read, mm_mat_write, mm_array_read, mm_array_write
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
public mm_vet_read, mm_vet_write
#endif
interface mm_array_read
subroutine mm_svet_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
real(psb_spk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svet_read
subroutine mm_dvet_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
real(psb_dpk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvet_read
subroutine mm_cvet_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
complex(psb_spk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvet_read
subroutine mm_zvet_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
complex(psb_dpk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet_read
subroutine mm_svet2_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
real(psb_spk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svet2_read
subroutine mm_dvet2_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
real(psb_dpk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvet2_read
subroutine mm_cvet2_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
complex(psb_spk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvet2_read
subroutine mm_zvet2_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
complex(psb_dpk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet2_read
subroutine mm_ivet_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet_read
subroutine mm_ivet2_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet2_read
#if defined(PSB_IPK4) && defined(PSB_LPK8)
subroutine mm_lvet_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvet_read
subroutine mm_lvet2_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvet2_read
#endif
subroutine mm_svect_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_s_vect_type
implicit none
type(psb_s_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svect_read
subroutine mm_dvect_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_d_vect_type
implicit none
type(psb_d_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvect_read
subroutine mm_cvect_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_c_vect_type
implicit none
type(psb_c_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvect_read
subroutine mm_zvect_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_z_vect_type
implicit none
type(psb_z_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvect_read
subroutine mm_ivect_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_i_vect_type
implicit none
type(psb_i_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivect_read
subroutine mm_lvect_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_l_vect_type
implicit none
type(psb_l_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvect_read
end interface
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_read
procedure mm_svet_read, mm_dvet_read, mm_cvet_read,&
& mm_zvet_read, mm_svet2_read, mm_dvet2_read, &
& mm_cvet2_read, mm_zvet2_read
end interface
#endif
interface mm_array_write
subroutine mm_svet2_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
real(psb_spk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svet2_write
subroutine mm_svet1_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
real(psb_spk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svet1_write
subroutine mm_dvet2_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
real(psb_dpk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvet2_write
subroutine mm_dvet1_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
real(psb_dpk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvet1_write
subroutine mm_cvet2_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
complex(psb_spk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvet2_write
subroutine mm_cvet1_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
complex(psb_spk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvet1_write
subroutine mm_zvet2_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
complex(psb_dpk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet2_write
subroutine mm_zvet1_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
complex(psb_dpk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet1_write
subroutine mm_ivet2_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet2_write
subroutine mm_ivet1_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet1_write
#if defined(PSB_IPK4) && defined(PSB_LPK8)
subroutine mm_lvet2_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvet2_write
subroutine mm_lvet1_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvet1_write
#endif
subroutine mm_svect_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_s_vect_type
implicit none
type(psb_s_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svect_write
subroutine mm_dvect_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_,psb_d_vect_type
implicit none
type(psb_d_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_dvect_write
subroutine mm_cvect_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_c_vect_type
implicit none
type(psb_c_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_cvect_write
subroutine mm_zvect_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_,psb_z_vect_type
implicit none
type(psb_z_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvect_write
subroutine mm_ivect_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_i_vect_type
implicit none
type(psb_i_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivect_write
subroutine mm_lvect_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_,psb_l_vect_type
implicit none
type(psb_l_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_lvect_write
end interface
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_write
procedure mm_svet1_write, mm_dvet1_write, mm_cvet1_write,&
& mm_zvet1_write, mm_svet2_write, mm_dvet2_write, &
& mm_cvet2_write, mm_zvet2_write, &
& mm_ivet1_write, mm_ivet2_write
end interface
#endif
interface mm_mat_read
subroutine smm_mat_read(a, info, iunit, filename)
import :: psb_sspmat_type, psb_ipk_
implicit none
type(psb_sspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine smm_mat_read
subroutine dmm_mat_read(a, info, iunit, filename)
import :: psb_dspmat_type, psb_ipk_
implicit none
type(psb_dspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine dmm_mat_read
subroutine cmm_mat_read(a, info, iunit, filename)
import :: psb_cspmat_type, psb_ipk_
implicit none
type(psb_cspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine cmm_mat_read
subroutine zmm_mat_read(a, info, iunit, filename)
import :: psb_zspmat_type, psb_ipk_
implicit none
type(psb_zspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine zmm_mat_read
subroutine lsmm_mat_read(a, info, iunit, filename)
import :: psb_lsspmat_type, psb_ipk_
implicit none
type(psb_lsspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lsmm_mat_read
subroutine ldmm_mat_read(a, info, iunit, filename)
import :: psb_ldspmat_type, psb_ipk_
implicit none
type(psb_ldspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine ldmm_mat_read
subroutine lcmm_mat_read(a, info, iunit, filename)
import :: psb_lcspmat_type, psb_ipk_
implicit none
type(psb_lcspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lcmm_mat_read
subroutine lzmm_mat_read(a, info, iunit, filename)
import :: psb_lzspmat_type, psb_ipk_
implicit none
type(psb_lzspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lzmm_mat_read
end interface
interface mm_mat_write
subroutine smm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_sspmat_type, psb_ipk_
implicit none
type(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine smm_mat_write
subroutine dmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_dspmat_type, psb_ipk_
implicit none
type(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine dmm_mat_write
subroutine cmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_cspmat_type, psb_ipk_
implicit none
type(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine cmm_mat_write
subroutine zmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_zspmat_type, psb_ipk_
implicit none
type(psb_zspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine zmm_mat_write
subroutine lsmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_lsspmat_type, psb_ipk_
implicit none
type(psb_lsspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lsmm_mat_write
subroutine ldmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_ldspmat_type, psb_ipk_
implicit none
type(psb_ldspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine ldmm_mat_write
subroutine lcmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_lcspmat_type, psb_ipk_
implicit none
type(psb_lcspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lcmm_mat_write
subroutine lzmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_lzspmat_type, psb_ipk_
implicit none
type(psb_lzspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lzmm_mat_write
end interface
use psb_i_mmio_mod
use psb_s_mmio_mod
use psb_d_mmio_mod
use psb_c_mmio_mod
use psb_z_mmio_mod
end module psb_mmio_mod

@ -0,0 +1,155 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
module psb_s_mmio_mod
use psb_base_mod, only : psb_ipk_, psb_lpk_, psb_spk_,&
& psb_s_vect_type, psb_sspmat_type, psb_lsspmat_type
!public mm_mat_read, mm_mat_write, mm_array_read, mm_array_write
interface mm_array_read
subroutine mm_svet_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
real(psb_spk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svet_read
subroutine mm_svet2_read(b, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
real(psb_spk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svet2_read
subroutine mm_svect_read(b, info, iunit, filename)
import :: psb_ipk_,psb_s_vect_type
implicit none
type(psb_s_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svect_read
end interface mm_array_read
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_read
procedure mm_svet_read, mm_svet2_read
end interface
#endif
#endif
interface mm_array_write
subroutine mm_svet2_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
real(psb_spk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svet2_write
subroutine mm_svet1_write(b, header, info, iunit, filename)
import :: psb_spk_, psb_ipk_
implicit none
real(psb_spk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svet1_write
subroutine mm_svect_write(b, header, info, iunit, filename)
import :: psb_ipk_, psb_s_vect_type
implicit none
type(psb_s_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_svect_write
end interface
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_write
procedure mm_svet1_write, mm_svet2_write
end interface
#endif
interface mm_mat_read
subroutine smm_mat_read(a, info, iunit, filename)
import :: psb_sspmat_type, psb_ipk_
implicit none
type(psb_sspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine smm_mat_read
subroutine lsmm_mat_read(a, info, iunit, filename)
import :: psb_lsspmat_type, psb_ipk_
implicit none
type(psb_lsspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lsmm_mat_read
end interface
interface mm_mat_write
subroutine smm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_sspmat_type, psb_ipk_
implicit none
type(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine smm_mat_write
subroutine lsmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_lsspmat_type, psb_ipk_
implicit none
type(psb_lsspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lsmm_mat_write
end interface
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
public mm_vet_read, mm_vet_write
#endif
#endif
end module psb_s_mmio_mod

@ -0,0 +1,155 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
module psb_z_mmio_mod
use psb_base_mod, only : psb_ipk_, psb_lpk_, psb_dpk_,&
& psb_z_vect_type, psb_zspmat_type, psb_lzspmat_type
!public mm_mat_read, mm_mat_write, mm_array_read, mm_array_write
interface mm_array_read
subroutine mm_zvet_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
complex(psb_dpk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet_read
subroutine mm_zvet2_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
complex(psb_dpk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet2_read
subroutine mm_zvect_read(b, info, iunit, filename)
import :: psb_ipk_,psb_z_vect_type
implicit none
type(psb_z_vect_type), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvect_read
end interface mm_array_read
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_read
procedure mm_zvet_read, mm_zvet2_read
end interface
#endif
#endif
interface mm_array_write
subroutine mm_zvet2_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
complex(psb_dpk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet2_write
subroutine mm_zvet1_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
complex(psb_dpk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet1_write
subroutine mm_zvect_write(b, header, info, iunit, filename)
import :: psb_ipk_, psb_z_vect_type
implicit none
type(psb_z_vect_type), intent(inout) :: b
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvect_write
end interface
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
interface mm_vet_write
procedure mm_zvet1_write, mm_zvet2_write
end interface
#endif
interface mm_mat_read
subroutine zmm_mat_read(a, info, iunit, filename)
import :: psb_zspmat_type, psb_ipk_
implicit none
type(psb_zspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine zmm_mat_read
subroutine lzmm_mat_read(a, info, iunit, filename)
import :: psb_lzspmat_type, psb_ipk_
implicit none
type(psb_lzspmat_type), intent(out) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lzmm_mat_read
end interface
interface mm_mat_write
subroutine zmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_zspmat_type, psb_ipk_
implicit none
type(psb_zspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine zmm_mat_write
subroutine lzmm_mat_write(a,mtitle,info,iunit,filename)
import :: psb_lzspmat_type, psb_ipk_
implicit none
type(psb_lzspmat_type), intent(in) :: a
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in) :: mtitle
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine lzmm_mat_write
end interface
#if 0
#if ! defined(PSB_HAVE_BUGGY_GENERICS)
public mm_vet_read, mm_vet_write
#endif
#endif
end module psb_z_mmio_mod
Loading…
Cancel
Save