diff --git a/base/modules/psblas/psb_d_psblas_mod.F90 b/base/modules/psblas/psb_d_psblas_mod.F90 index 53cbda43..fe0d7658 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -599,5 +599,17 @@ module psb_d_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_dmask_vect end interface + interface psb_minquotient + function psb_dminquotient_vect(x,y,desc_a,info,global) result(res) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + real(psb_dpk_) :: res + 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), optional :: global + end function + 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 80f1d19a..4544e011 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -599,5 +599,17 @@ module psb_s_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_smask_vect end interface + interface psb_minquotient + function psb_sminquotient_vect(x,y,desc_a,info,global) result(res) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + real(psb_spk_) :: res + 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), optional :: global + end function + end interface end module psb_s_psblas_mod diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index 733847ac..fbdcc0cc 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -207,10 +207,13 @@ module psb_d_base_vect_mod procedure, pass(z) :: addconst_v2 => d_base_addconst_v2 generic, public :: addconst => addconst_a2,addconst_v2 -procedure, pass(x) :: minreal => d_base_min -procedure, pass(m) :: mask_v => d_base_mask_v -procedure, pass(m) :: mask_a => d_base_mask_a -generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minreal => d_base_min + procedure, pass(m) :: mask_v => d_base_mask_v + procedure, pass(m) :: mask_a => d_base_mask_a + generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minquotient_v => d_base_minquotient_v + procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2 + generic, public :: minquotient => minquotient_v, minquotient_a2 @@ -1649,6 +1652,62 @@ contains end function d_base_min + ! + !> Function base_minquotient_v + !! \memberof psb_d_base_vect_type + !! \brief Minimum entry of the vector entry-by-entry divide x/y + !! \param x The numerator vector + !! \param y The denumerator vector + !! \param info return code + !! + function d_base_minquotient_v(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + + z = x%minquotient(y%v,info) + + end function d_base_minquotient_v + + ! + !> Function base_minquotient_a2 + !! \memberof psb_d_base_vect_type + !! \brief Minimum entry of the array entry-by-entry divide x/y + !! \param x The numerator array + !! \param y The denumerator array + !! \param info return code + !! + function d_base_minquotient_a2(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:) + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + real(psb_dpk_) :: temp + + info = 0 + + z = huge(z) + n = min(size(y), size(x%v)) + do i=1, n + if ( y(i) /= dzero ) then + temp = x%v(i)/y(i) + if (temp <= z) z = temp + end if + end do + + end function d_base_minquotient_a2 + + ! !> Function base_asum !! \memberof psb_d_base_vect_type diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 3b3011b9..f49db541 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -131,6 +131,9 @@ module psb_d_vect_mod procedure, pass(m) :: mask_v => d_vect_mask_v procedure, pass(m) :: mask_a => d_vect_mask_a generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minquotient_v => d_vect_minquotient_v + procedure, pass(x) :: minquotient_a2 => d_vect_minquotient_a2 + generic, public :: minquotient => minquotient_v, minquotient_a2 end type psb_d_vect_type @@ -1113,6 +1116,36 @@ contains end subroutine d_vect_mask_v + function d_vect_minquotient_v(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & z = x%v%minquotient(y%v,info) + + end function d_vect_minquotient_v + + function d_vect_minquotient_a2(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: z + + info = 0 + z = x%v%minquotient(y,info) + + end function d_vect_minquotient_a2 + + + subroutine d_vect_addconst_a2(x,b,z,info) 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 12d9f381..451baef5 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -207,10 +207,13 @@ module psb_s_base_vect_mod procedure, pass(z) :: addconst_v2 => s_base_addconst_v2 generic, public :: addconst => addconst_a2,addconst_v2 -procedure, pass(x) :: minreal => s_base_min -procedure, pass(m) :: mask_v => s_base_mask_v -procedure, pass(m) :: mask_a => s_base_mask_a -generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minreal => s_base_min + procedure, pass(m) :: mask_v => s_base_mask_v + procedure, pass(m) :: mask_a => s_base_mask_a + generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minquotient_v => s_base_minquotient_v + procedure, pass(x) :: minquotient_a2 => s_base_minquotient_a2 + generic, public :: minquotient => minquotient_v, minquotient_a2 @@ -1649,6 +1652,62 @@ contains end function s_base_min + ! + !> Function base_minquotient_v + !! \memberof psb_s_base_vect_type + !! \brief Minimum entry of the vector entry-by-entry divide x/y + !! \param x The numerator vector + !! \param y The denumerator vector + !! \param info return code + !! + function s_base_minquotient_v(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + + z = x%minquotient(y%v,info) + + end function s_base_minquotient_v + + ! + !> Function base_minquotient_a2 + !! \memberof psb_s_base_vect_type + !! \brief Minimum entry of the array entry-by-entry divide x/y + !! \param x The numerator array + !! \param y The denumerator array + !! \param info return code + !! + function s_base_minquotient_a2(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:) + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + real(psb_spk_) :: temp + + info = 0 + + z = huge(z) + n = min(size(y), size(x%v)) + do i=1, n + if ( y(i) /= szero ) then + temp = x%v(i)/y(i) + if (temp <= z) z = temp + end if + end do + + end function s_base_minquotient_a2 + + ! !> Function base_asum !! \memberof psb_s_base_vect_type diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 62ef21c7..aad99c9c 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -131,6 +131,9 @@ module psb_s_vect_mod procedure, pass(m) :: mask_v => s_vect_mask_v procedure, pass(m) :: mask_a => s_vect_mask_a generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minquotient_v => s_vect_minquotient_v + procedure, pass(x) :: minquotient_a2 => s_vect_minquotient_a2 + generic, public :: minquotient => minquotient_v, minquotient_a2 end type psb_s_vect_type @@ -1113,6 +1116,36 @@ contains end subroutine s_vect_mask_v + function s_vect_minquotient_v(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & z = x%v%minquotient(y%v,info) + + end function s_vect_minquotient_v + + function s_vect_minquotient_a2(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: z + + info = 0 + z = x%v%minquotient(y,info) + + end function s_vect_minquotient_a2 + + + subroutine s_vect_addconst_a2(x,b,z,info) use psi_serial_mod implicit none diff --git a/base/psblas/psb_cdiv_vect.f90 b/base/psblas/psb_cdiv_vect.f90 index 32fdba9d..3e709da4 100644 --- a/base/psblas/psb_cdiv_vect.f90 +++ b/base/psblas/psb_cdiv_vect.f90 @@ -351,3 +351,4 @@ subroutine psb_cdiv_vect2_check(x,y,z,desc_a,info,flag) return end subroutine psb_cdiv_vect2_check + diff --git a/base/psblas/psb_ddiv_vect.f90 b/base/psblas/psb_ddiv_vect.f90 index 90ddd1c4..d5a85913 100644 --- a/base/psblas/psb_ddiv_vect.f90 +++ b/base/psblas/psb_ddiv_vect.f90 @@ -351,3 +351,91 @@ subroutine psb_ddiv_vect2_check(x,y,z,desc_a,info,flag) return end subroutine psb_ddiv_vect2_check + +function psb_dminquotient_vect(x,y,desc_a,info,global) result(res) + use psb_penv_mod + use psb_serial_mod + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_d_vect_mod + implicit none + + real(psb_dpk_) :: res + 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), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + character(len=20) :: name, ch_err + + name='psb_dminquotient_vect' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) 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 (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + + m = desc_a%get_global_rows() + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then + res = x%minquotient(y,info) + else + res = dzero + end if + + ! compute global min + if (global_) call psb_min(ictxt, res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function psb_dminquotient_vect diff --git a/base/psblas/psb_sdiv_vect.f90 b/base/psblas/psb_sdiv_vect.f90 index 5e81abce..2fba3e73 100644 --- a/base/psblas/psb_sdiv_vect.f90 +++ b/base/psblas/psb_sdiv_vect.f90 @@ -351,3 +351,91 @@ subroutine psb_sdiv_vect2_check(x,y,z,desc_a,info,flag) return end subroutine psb_sdiv_vect2_check + +function psb_sminquotient_vect(x,y,desc_a,info,global) result(res) + use psb_penv_mod + use psb_serial_mod + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_s_vect_mod + implicit none + + real(psb_spk_) :: res + 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), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + character(len=20) :: name, ch_err + + name='psb_sminquotient_vect' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) 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 (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + + m = desc_a%get_global_rows() + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then + res = x%minquotient(y,info) + else + res = szero + end if + + ! compute global min + if (global_) call psb_min(ictxt, res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function psb_sminquotient_vect diff --git a/base/psblas/psb_zdiv_vect.f90 b/base/psblas/psb_zdiv_vect.f90 index 582f1233..f07f5d00 100644 --- a/base/psblas/psb_zdiv_vect.f90 +++ b/base/psblas/psb_zdiv_vect.f90 @@ -351,3 +351,4 @@ subroutine psb_zdiv_vect2_check(x,y,z,desc_a,info,flag) return end subroutine psb_zdiv_vect2_check + diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index 4e1b645e..04f5d232 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -77,7 +77,7 @@ psb_d_t psb_c_dgenrm2_weight(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_descripto psb_d_t psb_c_dgenrm2_weightmask(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_dvector *idvh,psb_c_descriptor *cdh); psb_i_t psb_c_dmask(psb_c_dvector *ch,psb_c_dvector *xh,psb_c_dvector *mh, bool t, psb_c_descriptor *cdh); psb_d_t psb_c_dgemin(psb_c_dvector *xh,psb_c_descriptor *cdh); - +psb_d_t psb_c_dminquotient(psb_c_dvector *xh,psb_c_dvector *yh, psb_c_descriptor *cdh); #ifdef __cplusplus } diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 index 6b0b7994..37d315c0 100644 --- a/cbind/base/psb_d_psblas_cbind_mod.f90 +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -536,6 +536,40 @@ contains end function psb_c_dmask + function psb_c_dminquotient(xh,yh,cdh) bind(c) result(res) + implicit none + real(psb_dpk_) :: res + + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + 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(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + res = psb_minquotient(xp,yp,descp,info) + + + end function psb_c_dminquotient + function psb_c_dgenrm2(xh,cdh) bind(c) result(res) implicit none real(c_double) :: res diff --git a/cbind/base/psb_s_psblas_cbind_mod.f90 b/cbind/base/psb_s_psblas_cbind_mod.f90 index 057992f6..dd42f6f5 100644 --- a/cbind/base/psb_s_psblas_cbind_mod.f90 +++ b/cbind/base/psb_s_psblas_cbind_mod.f90 @@ -536,6 +536,40 @@ contains end function psb_c_smask + function psb_c_sminquotient(xh,yh,cdh) bind(c) result(res) + implicit none + real(psb_spk_) :: res + + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp + 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(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + res = psb_minquotient(xp,yp,descp,info) + + + end function psb_c_sminquotient + function psb_c_sgenrm2(xh,cdh) bind(c) result(res) implicit none real(c_float) :: res