mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-06 22:55:08 +00:00
Added psb_minquotient function with C interface
This commit is contained in:
Cirdans-Home
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -351,3 +351,4 @@ subroutine psb_cdiv_vect2_check(x,y,z,desc_a,info,flag)
|
||||
return
|
||||
|
||||
end subroutine psb_cdiv_vect2_check
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -351,3 +351,4 @@ subroutine psb_zdiv_vect2_check(x,y,z,desc_a,info,flag)
|
||||
return
|
||||
|
||||
end subroutine psb_zdiv_vect2_check
|
||||
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user