diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index 1e16312d..8e9a286a 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -448,6 +448,15 @@ module psb_c_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_cdiv_vect + subroutine psb_cdiv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_cdiv_vect_check end interface end module psb_c_psblas_mod diff --git a/base/modules/psblas/psb_d_psblas_mod.F90 b/base/modules/psblas/psb_d_psblas_mod.F90 index f7bdfa8f..993ac542 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -448,6 +448,15 @@ module psb_d_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_ddiv_vect + subroutine psb_ddiv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_ddiv_vect_check end interface end module psb_d_psblas_mod diff --git a/base/modules/psblas/psb_s_psblas_mod.F90 b/base/modules/psblas/psb_s_psblas_mod.F90 index af2c17f6..1a2347d1 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -448,6 +448,15 @@ module psb_s_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_sdiv_vect + subroutine psb_sdiv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_sdiv_vect_check end interface end module psb_s_psblas_mod diff --git a/base/modules/psblas/psb_z_psblas_mod.F90 b/base/modules/psblas/psb_z_psblas_mod.F90 index 807ec7cd..7fd96c4c 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -448,6 +448,15 @@ module psb_z_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_zdiv_vect + subroutine psb_zdiv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_zdiv_vect_check end interface end module psb_z_psblas_mod diff --git a/base/modules/serial/psb_c_base_vect_mod.f90 b/base/modules/serial/psb_c_base_vect_mod.f90 index d9531474..3927a60b 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -166,9 +166,11 @@ module psb_c_base_vect_mod ! ! Vector-Vector operations ! - procedure, pass(x) :: div_v => c_base_div_v - procedure, pass(z) :: div_a2 => c_base_div_a2 - generic, public :: div => div_v, div_a2 + procedure, pass(x) :: div_v => c_base_div_v + procedure, pass(x) :: div_v_check => c_base_div_v_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_v_check, div_a2, div_a2_check ! ! Scaling and norms ! @@ -1205,10 +1207,32 @@ contains end subroutine c_base_div_v ! + !> Function base_div_v_check + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine c_base_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info,flag) + + + end subroutine c_base_div_v_check + ! !> Function base_div_a2 !! \memberof psb_c_base_vect_type !! \brief Entry-by-entry divide between normal array x=x/y - !! \param x(:) The array to be multiplied by + !! \param y(:) The array to be divided by !! \param info return code !! subroutine c_base_div_a2(x, y, z, info) @@ -1229,7 +1253,43 @@ contains end do end subroutine c_base_div_a2 + ! + !> Function base_div_a2_check + !! \memberof psb_c_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + subroutine c_base_div_a2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call c_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + end subroutine c_base_div_a2_check ! diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index 02965a3c..d4eb5a2a 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -95,8 +95,10 @@ module psb_c_vect_mod 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(x) :: div_v_check => c_vect_div_v_check procedure, pass(z) :: div_a2 => c_vect_div_a2 - generic, public :: div => div_v, div_a2 + procedure, pass(z) :: div_a2_check => c_vect_div_a2_check + generic, public :: div => div_v, div_v_check, div_a2, div_a2_check procedure, pass(x) :: scal => c_vect_scal procedure, pass(x) :: absval1 => c_vect_absval1 procedure, pass(x) :: absval2 => c_vect_absval2 @@ -744,6 +746,21 @@ contains end subroutine c_vect_div_v + subroutine c_vect_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine c_vect_div_v_check + subroutine c_vect_div_a2(x, y, z, info) use psi_serial_mod implicit none @@ -759,6 +776,22 @@ contains end subroutine c_vect_div_a2 + subroutine c_vect_div_a2_check(x, y, z, info,flag) + use psi_serial_mod + implicit none + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine c_vect_div_a2_check + subroutine c_vect_scal(alpha, x) use psi_serial_mod implicit none diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index 4d3bb161..3d00bbef 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -166,9 +166,11 @@ module psb_d_base_vect_mod ! ! Vector-Vector operations ! - procedure, pass(x) :: div_v => d_base_div_v - procedure, pass(z) :: div_a2 => d_base_div_a2 - generic, public :: div => div_v, div_a2 + procedure, pass(x) :: div_v => d_base_div_v + procedure, pass(x) :: div_v_check => d_base_div_v_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_v_check, div_a2, div_a2_check ! ! Scaling and norms ! @@ -1205,10 +1207,32 @@ contains end subroutine d_base_div_v ! + !> Function base_div_v_check + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine d_base_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info,flag) + + + end subroutine d_base_div_v_check + ! !> Function base_div_a2 !! \memberof psb_d_base_vect_type !! \brief Entry-by-entry divide between normal array x=x/y - !! \param x(:) The array to be multiplied by + !! \param y(:) The array to be divided by !! \param info return code !! subroutine d_base_div_a2(x, y, z, info) @@ -1229,7 +1253,43 @@ contains end do end subroutine d_base_div_a2 + ! + !> Function base_div_a2_check + !! \memberof psb_d_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + subroutine d_base_div_a2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call d_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + end subroutine d_base_div_a2_check ! diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 469cb56d..e7cf6757 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -95,8 +95,10 @@ module psb_d_vect_mod 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(x) :: div_v_check => d_vect_div_v_check procedure, pass(z) :: div_a2 => d_vect_div_a2 - generic, public :: div => div_v, div_a2 + procedure, pass(z) :: div_a2_check => d_vect_div_a2_check + generic, public :: div => div_v, div_v_check, div_a2, div_a2_check procedure, pass(x) :: scal => d_vect_scal procedure, pass(x) :: absval1 => d_vect_absval1 procedure, pass(x) :: absval2 => d_vect_absval2 @@ -744,6 +746,21 @@ contains end subroutine d_vect_div_v + subroutine d_vect_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine d_vect_div_v_check + subroutine d_vect_div_a2(x, y, z, info) use psi_serial_mod implicit none @@ -759,6 +776,22 @@ contains end subroutine d_vect_div_a2 + subroutine d_vect_div_a2_check(x, y, z, info,flag) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine d_vect_div_a2_check + subroutine d_vect_scal(alpha, x) use psi_serial_mod implicit none diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index a47d6377..bf229956 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -166,9 +166,11 @@ module psb_s_base_vect_mod ! ! Vector-Vector operations ! - procedure, pass(x) :: div_v => s_base_div_v - procedure, pass(z) :: div_a2 => s_base_div_a2 - generic, public :: div => div_v, div_a2 + procedure, pass(x) :: div_v => s_base_div_v + procedure, pass(x) :: div_v_check => s_base_div_v_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_v_check, div_a2, div_a2_check ! ! Scaling and norms ! @@ -1205,10 +1207,32 @@ contains end subroutine s_base_div_v ! + !> Function base_div_v_check + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine s_base_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info,flag) + + + end subroutine s_base_div_v_check + ! !> Function base_div_a2 !! \memberof psb_s_base_vect_type !! \brief Entry-by-entry divide between normal array x=x/y - !! \param x(:) The array to be multiplied by + !! \param y(:) The array to be divided by !! \param info return code !! subroutine s_base_div_a2(x, y, z, info) @@ -1229,7 +1253,43 @@ contains end do end subroutine s_base_div_a2 + ! + !> Function base_div_a2_check + !! \memberof psb_s_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + subroutine s_base_div_a2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call s_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + end subroutine s_base_div_a2_check ! diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index d835bc5a..22519456 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -95,8 +95,10 @@ module psb_s_vect_mod 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(x) :: div_v_check => s_vect_div_v_check procedure, pass(z) :: div_a2 => s_vect_div_a2 - generic, public :: div => div_v, div_a2 + procedure, pass(z) :: div_a2_check => s_vect_div_a2_check + generic, public :: div => div_v, div_v_check, div_a2, div_a2_check procedure, pass(x) :: scal => s_vect_scal procedure, pass(x) :: absval1 => s_vect_absval1 procedure, pass(x) :: absval2 => s_vect_absval2 @@ -744,6 +746,21 @@ contains end subroutine s_vect_div_v + subroutine s_vect_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine s_vect_div_v_check + subroutine s_vect_div_a2(x, y, z, info) use psi_serial_mod implicit none @@ -759,6 +776,22 @@ contains end subroutine s_vect_div_a2 + subroutine s_vect_div_a2_check(x, y, z, info,flag) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine s_vect_div_a2_check + subroutine s_vect_scal(alpha, x) use psi_serial_mod implicit none diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index 350e7034..91663600 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -166,9 +166,11 @@ module psb_z_base_vect_mod ! ! Vector-Vector operations ! - procedure, pass(x) :: div_v => z_base_div_v - procedure, pass(z) :: div_a2 => z_base_div_a2 - generic, public :: div => div_v, div_a2 + procedure, pass(x) :: div_v => z_base_div_v + procedure, pass(x) :: div_v_check => z_base_div_v_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_v_check, div_a2, div_a2_check ! ! Scaling and norms ! @@ -1205,10 +1207,32 @@ contains end subroutine z_base_div_v ! + !> Function base_div_v_check + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine z_base_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info,flag) + + + end subroutine z_base_div_v_check + ! !> Function base_div_a2 !! \memberof psb_z_base_vect_type !! \brief Entry-by-entry divide between normal array x=x/y - !! \param x(:) The array to be multiplied by + !! \param y(:) The array to be divided by !! \param info return code !! subroutine z_base_div_a2(x, y, z, info) @@ -1229,7 +1253,43 @@ contains end do end subroutine z_base_div_a2 + ! + !> Function base_div_a2_check + !! \memberof psb_z_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + subroutine z_base_div_a2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call z_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + end subroutine z_base_div_a2_check ! diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index b65ba18b..f5e4f31a 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -95,8 +95,10 @@ module psb_z_vect_mod 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(x) :: div_v_check => z_vect_div_v_check procedure, pass(z) :: div_a2 => z_vect_div_a2 - generic, public :: div => div_v, div_a2 + procedure, pass(z) :: div_a2_check => z_vect_div_a2_check + generic, public :: div => div_v, div_v_check, div_a2, div_a2_check procedure, pass(x) :: scal => z_vect_scal procedure, pass(x) :: absval1 => z_vect_absval1 procedure, pass(x) :: absval2 => z_vect_absval2 @@ -744,6 +746,21 @@ contains end subroutine z_vect_div_v + subroutine z_vect_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine z_vect_div_v_check + subroutine z_vect_div_a2(x, y, z, info) use psi_serial_mod implicit none @@ -759,6 +776,22 @@ contains end subroutine z_vect_div_a2 + subroutine z_vect_div_a2_check(x, y, z, info,flag) + use psi_serial_mod + implicit none + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine z_vect_div_a2_check + subroutine z_vect_scal(alpha, x) use psi_serial_mod implicit none diff --git a/base/psblas/psb_cdiv_vect.f90 b/base/psblas/psb_cdiv_vect.f90 index 38c7ce6a..99e4fef6 100644 --- a/base/psblas/psb_cdiv_vect.f90 +++ b/base/psblas/psb_cdiv_vect.f90 @@ -103,3 +103,77 @@ subroutine psb_cdiv_vect(x,y,desc_a,info) return end subroutine psb_cdiv_vect + +subroutine psb_cdiv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_cdiv_vect_check + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_div_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cdiv_vect_check diff --git a/base/psblas/psb_ddiv_vect.f90 b/base/psblas/psb_ddiv_vect.f90 index d9ab0203..20536a2c 100644 --- a/base/psblas/psb_ddiv_vect.f90 +++ b/base/psblas/psb_ddiv_vect.f90 @@ -103,3 +103,77 @@ subroutine psb_ddiv_vect(x,y,desc_a,info) return end subroutine psb_ddiv_vect + +subroutine psb_ddiv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_ddiv_vect_check + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_div_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ddiv_vect_check diff --git a/base/psblas/psb_sdiv_vect.f90 b/base/psblas/psb_sdiv_vect.f90 index 99a1ce7c..42bc8b83 100644 --- a/base/psblas/psb_sdiv_vect.f90 +++ b/base/psblas/psb_sdiv_vect.f90 @@ -103,3 +103,77 @@ subroutine psb_sdiv_vect(x,y,desc_a,info) return end subroutine psb_sdiv_vect + +subroutine psb_sdiv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_sdiv_vect_check + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_div_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sdiv_vect_check diff --git a/base/psblas/psb_zdiv_vect.f90 b/base/psblas/psb_zdiv_vect.f90 index 949cbf7d..5ef0552a 100644 --- a/base/psblas/psb_zdiv_vect.f90 +++ b/base/psblas/psb_zdiv_vect.f90 @@ -103,3 +103,77 @@ subroutine psb_zdiv_vect(x,y,desc_a,info) return end subroutine psb_zdiv_vect + +subroutine psb_zdiv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_zdiv_vect_check + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_div_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zdiv_vect_check