fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-06 22:55:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Removed the out-interface for vector scaling

Browse Source
This commit is contained in:
Cirdans-Home
2020-03-30 21:48:26 +02:00
parent 82db0f43b4
commit 5504e34161
26 changed files with 81 additions and 947 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psblas/psb_c_psblas_mod.F90
-11
View File
@@ -586,17 +586,6 @@ module psb_c_psblas_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psb_caddconst_vect
end interface
interface psb_gescal
subroutine psb_cscal_vect(x,c,z,desc_a,info)
import :: psb_desc_type, psb_ipk_, &
& psb_c_vect_type, psb_spk_
type(psb_c_vect_type), intent (inout) :: x
type(psb_c_vect_type), intent (inout) :: z
real(psb_spk_), intent(in) :: c
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cscal_vect
end interface
end module psb_c_psblas_mod
base/modules/psblas/psb_d_psblas_mod.F90
-11
View File
@@ -597,17 +597,6 @@ module psb_d_psblas_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psb_daddconst_vect
end interface
interface psb_gescal
subroutine psb_dscal_vect(x,c,z,desc_a,info)
import :: psb_desc_type, psb_ipk_, &
& psb_d_vect_type, psb_dpk_
type(psb_d_vect_type), intent (inout) :: x
type(psb_d_vect_type), intent (inout) :: z
real(psb_dpk_), intent(in) :: c
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_dscal_vect
end interface
interface psb_mask
subroutine psb_dmask_vect(c,x,m,t,desc_a,info)
base/modules/psblas/psb_s_psblas_mod.F90
-11
View File
@@ -597,17 +597,6 @@ module psb_s_psblas_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psb_saddconst_vect
end interface
interface psb_gescal
subroutine psb_sscal_vect(x,c,z,desc_a,info)
import :: psb_desc_type, psb_ipk_, &
& psb_s_vect_type, psb_spk_
type(psb_s_vect_type), intent (inout) :: x
type(psb_s_vect_type), intent (inout) :: z
real(psb_spk_), intent(in) :: c
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_sscal_vect
end interface
interface psb_mask
subroutine psb_smask_vect(c,x,m,t,desc_a,info)
base/modules/psblas/psb_z_psblas_mod.F90
-11
View File
@@ -586,17 +586,6 @@ module psb_z_psblas_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psb_zaddconst_vect
end interface
interface psb_gescal
subroutine psb_zscal_vect(x,c,z,desc_a,info)
import :: psb_desc_type, psb_ipk_, &
& psb_z_vect_type, psb_dpk_
type(psb_z_vect_type), intent (inout) :: x
type(psb_z_vect_type), intent (inout) :: z
real(psb_dpk_), intent(in) :: c
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_zscal_vect
end interface
end module psb_z_psblas_mod
base/modules/serial/psb_c_base_vect_mod.f90
+1 -54
View File
@@ -185,10 +185,7 @@ module psb_c_base_vect_mod
!
! Scaling and norms
!
procedure, pass(x) :: scal_v => c_base_scal
procedure, pass(z) :: scal_v2 => c_base_scal_v2
procedure, pass(z) :: scal_a2 => c_base_scal_a2
generic, public :: scal => scal_v, scal_v2, scal_a2
procedure, pass(x) :: scal => c_base_scal
procedure, pass(x) :: absval1 => c_base_absval1
procedure, pass(x) :: absval2 => c_base_absval2
generic, public :: absval => absval1, absval2
@@ -1608,56 +1605,6 @@ contains
end subroutine c_base_scal
!
!> Function base_scal_a2
!! \memberof psb_c_base_vect_type
!! \brief Out of place scaling of the array x
!! \param x The array to be scaled
!! \param z The scaled vector z = c*x
!! \param c The scaling term
!! \param info return code
!
subroutine c_base_scal_a2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_spk_), intent(in) :: c
complex(psb_spk_), intent(inout) :: x(:)
class(psb_c_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,n
if (z%is_dev()) call z%sync()
n = size(x)
do i = 1, n, 1
z%v(i) = c*x(i)
end do
info = 0
end subroutine c_base_scal_a2
!
!> Function base_cmp_v2
!! \memberof psb_c_base_vect_type
!! \brief Out of place scaling of the vector x
!! \param x The vector to be scaled
!! \param z The scaled vector z = c*x
!! \param c The scaling term
!! \param info return code
!
subroutine c_base_scal_v2(x,c,z,info)
use psi_serial_mod
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
real(psb_spk_), intent(in) :: c
class(psb_c_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (x%is_dev()) call x%sync()
call z%scal(x%v,c,info)
end subroutine c_base_scal_v2
!
! Norms 1, 2 and infinity
!
base/modules/serial/psb_c_vect_mod.F90
+1 -32
View File
@@ -109,10 +109,7 @@ module psb_c_vect_mod
procedure, pass(y) :: inv_a2 => c_vect_inv_a2
procedure, pass(y) :: inv_a2_check => c_vect_inv_a2_check
generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check
procedure, pass(x) :: scal_v => c_vect_scal
procedure, pass(z) :: scal_v2 => c_vect_scal_v2
procedure, pass(z) :: scal_a2 => c_vect_scal_a2
generic, public :: scal => scal_v, scal_v2, scal_a2
procedure, pass(x) :: scal => c_vect_scal
procedure, pass(x) :: absval1 => c_vect_absval1
procedure, pass(x) :: absval2 => c_vect_absval2
generic, public :: absval => absval1, absval2
@@ -974,34 +971,6 @@ contains
end subroutine c_vect_scal
subroutine c_vect_scal_a2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_spk_), intent(in) :: c
complex(psb_spk_), intent(inout) :: x(:)
class(psb_c_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(z%v)) &
& call z%scal(x,c,info)
end subroutine c_vect_scal_a2
subroutine c_vect_scal_v2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_spk_), intent(in) :: c
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v).and.allocated(z%v)) &
& call z%v%scal(x%v,c,info)
end subroutine c_vect_scal_v2
subroutine c_vect_absval1(x)
class(psb_c_vect_type), intent(inout) :: x
base/modules/serial/psb_d_base_vect_mod.f90
+1 -54
View File
@@ -185,10 +185,7 @@ module psb_d_base_vect_mod
!
! Scaling and norms
!
procedure, pass(x) :: scal_v => d_base_scal
procedure, pass(z) :: scal_v2 => d_base_scal_v2
procedure, pass(z) :: scal_a2 => d_base_scal_a2
generic, public :: scal => scal_v, scal_v2, scal_a2
procedure, pass(x) :: scal => d_base_scal
procedure, pass(x) :: absval1 => d_base_absval1
procedure, pass(x) :: absval2 => d_base_absval2
generic, public :: absval => absval1, absval2
@@ -1615,56 +1612,6 @@ contains
end subroutine d_base_scal
!
!> Function base_scal_a2
!! \memberof psb_d_base_vect_type
!! \brief Out of place scaling of the array x
!! \param x The array to be scaled
!! \param z The scaled vector z = c*x
!! \param c The scaling term
!! \param info return code
!
subroutine d_base_scal_a2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_dpk_), intent(in) :: c
real(psb_dpk_), intent(inout) :: x(:)
class(psb_d_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,n
if (z%is_dev()) call z%sync()
n = size(x)
do i = 1, n, 1
z%v(i) = c*x(i)
end do
info = 0
end subroutine d_base_scal_a2
!
!> Function base_cmp_v2
!! \memberof psb_d_base_vect_type
!! \brief Out of place scaling of the vector x
!! \param x The vector to be scaled
!! \param z The scaled vector z = c*x
!! \param c The scaling term
!! \param info return code
!
subroutine d_base_scal_v2(x,c,z,info)
use psi_serial_mod
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
real(psb_dpk_), intent(in) :: c
class(psb_d_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (x%is_dev()) call x%sync()
call z%scal(x%v,c,info)
end subroutine d_base_scal_v2
!
! Norms 1, 2 and infinity
!
base/modules/serial/psb_d_vect_mod.F90
+1 -32
View File
@@ -109,10 +109,7 @@ module psb_d_vect_mod
procedure, pass(y) :: inv_a2 => d_vect_inv_a2
procedure, pass(y) :: inv_a2_check => d_vect_inv_a2_check
generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check
procedure, pass(x) :: scal_v => d_vect_scal
procedure, pass(z) :: scal_v2 => d_vect_scal_v2
procedure, pass(z) :: scal_a2 => d_vect_scal_a2
generic, public :: scal => scal_v, scal_v2, scal_a2
procedure, pass(x) :: scal => d_vect_scal
procedure, pass(x) :: absval1 => d_vect_absval1
procedure, pass(x) :: absval2 => d_vect_absval2
generic, public :: absval => absval1, absval2
@@ -981,34 +978,6 @@ contains
end subroutine d_vect_scal
subroutine d_vect_scal_a2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_dpk_), intent(in) :: c
real(psb_dpk_), intent(inout) :: x(:)
class(psb_d_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(z%v)) &
& call z%scal(x,c,info)
end subroutine d_vect_scal_a2
subroutine d_vect_scal_v2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_dpk_), intent(in) :: c
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v).and.allocated(z%v)) &
& call z%v%scal(x%v,c,info)
end subroutine d_vect_scal_v2
subroutine d_vect_absval1(x)
class(psb_d_vect_type), intent(inout) :: x
base/modules/serial/psb_s_base_vect_mod.f90
+1 -54
View File
@@ -185,10 +185,7 @@ module psb_s_base_vect_mod
!
! Scaling and norms
!
procedure, pass(x) :: scal_v => s_base_scal
procedure, pass(z) :: scal_v2 => s_base_scal_v2
procedure, pass(z) :: scal_a2 => s_base_scal_a2
generic, public :: scal => scal_v, scal_v2, scal_a2
procedure, pass(x) :: scal => s_base_scal
procedure, pass(x) :: absval1 => s_base_absval1
procedure, pass(x) :: absval2 => s_base_absval2
generic, public :: absval => absval1, absval2
@@ -1615,56 +1612,6 @@ contains
end subroutine s_base_scal
!
!> Function base_scal_a2
!! \memberof psb_s_base_vect_type
!! \brief Out of place scaling of the array x
!! \param x The array to be scaled
!! \param z The scaled vector z = c*x
!! \param c The scaling term
!! \param info return code
!
subroutine s_base_scal_a2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_spk_), intent(in) :: c
real(psb_spk_), intent(inout) :: x(:)
class(psb_s_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,n
if (z%is_dev()) call z%sync()
n = size(x)
do i = 1, n, 1
z%v(i) = c*x(i)
end do
info = 0
end subroutine s_base_scal_a2
!
!> Function base_cmp_v2
!! \memberof psb_s_base_vect_type
!! \brief Out of place scaling of the vector x
!! \param x The vector to be scaled
!! \param z The scaled vector z = c*x
!! \param c The scaling term
!! \param info return code
!
subroutine s_base_scal_v2(x,c,z,info)
use psi_serial_mod
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
real(psb_spk_), intent(in) :: c
class(psb_s_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (x%is_dev()) call x%sync()
call z%scal(x%v,c,info)
end subroutine s_base_scal_v2
!
! Norms 1, 2 and infinity
!
base/modules/serial/psb_s_vect_mod.F90
+1 -32
View File
@@ -109,10 +109,7 @@ module psb_s_vect_mod
procedure, pass(y) :: inv_a2 => s_vect_inv_a2
procedure, pass(y) :: inv_a2_check => s_vect_inv_a2_check
generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check
procedure, pass(x) :: scal_v => s_vect_scal
procedure, pass(z) :: scal_v2 => s_vect_scal_v2
procedure, pass(z) :: scal_a2 => s_vect_scal_a2
generic, public :: scal => scal_v, scal_v2, scal_a2
procedure, pass(x) :: scal => s_vect_scal
procedure, pass(x) :: absval1 => s_vect_absval1
procedure, pass(x) :: absval2 => s_vect_absval2
generic, public :: absval => absval1, absval2
@@ -981,34 +978,6 @@ contains
end subroutine s_vect_scal
subroutine s_vect_scal_a2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_spk_), intent(in) :: c
real(psb_spk_), intent(inout) :: x(:)
class(psb_s_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(z%v)) &
& call z%scal(x,c,info)
end subroutine s_vect_scal_a2
subroutine s_vect_scal_v2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_spk_), intent(in) :: c
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v).and.allocated(z%v)) &
& call z%v%scal(x%v,c,info)
end subroutine s_vect_scal_v2
subroutine s_vect_absval1(x)
class(psb_s_vect_type), intent(inout) :: x
base/modules/serial/psb_z_base_vect_mod.f90
+1 -54
View File
@@ -185,10 +185,7 @@ module psb_z_base_vect_mod
!
! Scaling and norms
!
procedure, pass(x) :: scal_v => z_base_scal
procedure, pass(z) :: scal_v2 => z_base_scal_v2
procedure, pass(z) :: scal_a2 => z_base_scal_a2
generic, public :: scal => scal_v, scal_v2, scal_a2
procedure, pass(x) :: scal => z_base_scal
procedure, pass(x) :: absval1 => z_base_absval1
procedure, pass(x) :: absval2 => z_base_absval2
generic, public :: absval => absval1, absval2
@@ -1608,56 +1605,6 @@ contains
end subroutine z_base_scal
!
!> Function base_scal_a2
!! \memberof psb_z_base_vect_type
!! \brief Out of place scaling of the array x
!! \param x The array to be scaled
!! \param z The scaled vector z = c*x
!! \param c The scaling term
!! \param info return code
!
subroutine z_base_scal_a2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_dpk_), intent(in) :: c
complex(psb_dpk_), intent(inout) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,n
if (z%is_dev()) call z%sync()
n = size(x)
do i = 1, n, 1
z%v(i) = c*x(i)
end do
info = 0
end subroutine z_base_scal_a2
!
!> Function base_cmp_v2
!! \memberof psb_z_base_vect_type
!! \brief Out of place scaling of the vector x
!! \param x The vector to be scaled
!! \param z The scaled vector z = c*x
!! \param c The scaling term
!! \param info return code
!
subroutine z_base_scal_v2(x,c,z,info)
use psi_serial_mod
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
real(psb_dpk_), intent(in) :: c
class(psb_z_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (x%is_dev()) call x%sync()
call z%scal(x%v,c,info)
end subroutine z_base_scal_v2
!
! Norms 1, 2 and infinity
!
base/modules/serial/psb_z_vect_mod.F90
+1 -32
View File
@@ -109,10 +109,7 @@ module psb_z_vect_mod
procedure, pass(y) :: inv_a2 => z_vect_inv_a2
procedure, pass(y) :: inv_a2_check => z_vect_inv_a2_check
generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check
procedure, pass(x) :: scal_v => z_vect_scal
procedure, pass(z) :: scal_v2 => z_vect_scal_v2
procedure, pass(z) :: scal_a2 => z_vect_scal_a2
generic, public :: scal => scal_v, scal_v2, scal_a2
procedure, pass(x) :: scal => z_vect_scal
procedure, pass(x) :: absval1 => z_vect_absval1
procedure, pass(x) :: absval2 => z_vect_absval2
generic, public :: absval => absval1, absval2
@@ -974,34 +971,6 @@ contains
end subroutine z_vect_scal
subroutine z_vect_scal_a2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_dpk_), intent(in) :: c
complex(psb_dpk_), intent(inout) :: x(:)
class(psb_z_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(z%v)) &
& call z%scal(x,c,info)
end subroutine z_vect_scal_a2
subroutine z_vect_scal_v2(x,c,z,info)
use psi_serial_mod
implicit none
real(psb_dpk_), intent(in) :: c
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v).and.allocated(z%v)) &
& call z%v%scal(x%v,c,info)
end subroutine z_vect_scal_v2
subroutine z_vect_absval1(x)
class(psb_z_vect_type), intent(inout) :: x
base/psblas/psb_caxpby.f90
-85
View File
@@ -735,88 +735,3 @@ subroutine psb_caddconst_vect(x,b,z,desc_a,info)
return
end subroutine psb_caddconst_vect
!
! Subroutine: psb_cscal_vect
! Scale one distributed vector with scalar c,
!
! Z(i) := c*X(i)
!
! Arguments:
! x - type(psb_c_vect_type) The input vector containing the entries of X
! c - complex,input The scalar used to add each component of X
! z - type(psb_c_vect_type) The input/output vector Z
! desc_a - type(psb_desc_type) The communication descriptor.
! info - integer Return code
!
subroutine psb_cscal_vect(x,c,z,desc_a,info)
use psb_base_mod, psb_protect_name => psb_cscal_vect
implicit none
type(psb_c_vect_type), intent (inout) :: x
type(psb_c_vect_type), intent (inout) :: z
real(psb_spk_), intent(in) :: c
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! 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_scal_vect'
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(z%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,z%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 z%scal(x,c,info)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cscal_vect
base/psblas/psb_daxpby.f90
-85
View File
@@ -735,88 +735,3 @@ subroutine psb_daddconst_vect(x,b,z,desc_a,info)
return
end subroutine psb_daddconst_vect
!
! Subroutine: psb_dscal_vect
! Scale one distributed vector with scalar c,
!
! Z(i) := c*X(i)
!
! Arguments:
! x - type(psb_d_vect_type) The input vector containing the entries of X
! c - real,input The scalar used to add each component of X
! z - type(psb_d_vect_type) The input/output vector Z
! desc_a - type(psb_desc_type) The communication descriptor.
! info - integer Return code
!
subroutine psb_dscal_vect(x,c,z,desc_a,info)
use psb_base_mod, psb_protect_name => psb_dscal_vect
implicit none
type(psb_d_vect_type), intent (inout) :: x
type(psb_d_vect_type), intent (inout) :: z
real(psb_dpk_), intent(in) :: c
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! 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_scal_vect'
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(z%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,z%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 z%scal(x,c,info)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dscal_vect
base/psblas/psb_saxpby.f90
-85
View File
@@ -735,88 +735,3 @@ subroutine psb_saddconst_vect(x,b,z,desc_a,info)
return
end subroutine psb_saddconst_vect
!
! Subroutine: psb_sscal_vect
! Scale one distributed vector with scalar c,
!
! Z(i) := c*X(i)
!
! Arguments:
! x - type(psb_s_vect_type) The input vector containing the entries of X
! c - real,input The scalar used to add each component of X
! z - type(psb_s_vect_type) The input/output vector Z
! desc_a - type(psb_desc_type) The communication descriptor.
! info - integer Return code
!
subroutine psb_sscal_vect(x,c,z,desc_a,info)
use psb_base_mod, psb_protect_name => psb_sscal_vect
implicit none
type(psb_s_vect_type), intent (inout) :: x
type(psb_s_vect_type), intent (inout) :: z
real(psb_spk_), intent(in) :: c
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! 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_scal_vect'
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(z%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,z%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 z%scal(x,c,info)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sscal_vect
base/psblas/psb_zaxpby.f90
-85
View File
@@ -735,88 +735,3 @@ subroutine psb_zaddconst_vect(x,b,z,desc_a,info)
return
end subroutine psb_zaddconst_vect
!
! Subroutine: psb_zscal_vect
! Scale one distributed vector with scalar c,
!
! Z(i) := c*X(i)
!
! Arguments:
! x - type(psb_z_vect_type) The input vector containing the entries of X
! c - complex,input The scalar used to add each component of X
! z - type(psb_z_vect_type) The input/output vector Z
! desc_a - type(psb_desc_type) The communication descriptor.
! info - integer Return code
!
subroutine psb_zscal_vect(x,c,z,desc_a,info)
use psb_base_mod, psb_protect_name => psb_zscal_vect
implicit none
type(psb_z_vect_type), intent (inout) :: x
type(psb_z_vect_type), intent (inout) :: z
real(psb_dpk_), intent(in) :: c
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! 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_scal_vect'
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(z%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,z%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 z%scal(x,c,info)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zscal_vect
cbind/base/psb_base_tools_cbind_mod.F90
+65 -64
View File
@@ -4,27 +4,29 @@ module psb_base_tools_cbind_mod
use psb_objhandle_mod
use psb_cpenv_mod
use psb_base_string_cbind_mod
contains
! Aggiungere funzione per estrarre comunicatore
function psb_c_error() bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
implicit none
integer(psb_c_ipk_) :: res
res = 0
call psb_error()
end function psb_c_error
function psb_c_clean_errstack() bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
implicit none
integer(psb_c_ipk_) :: res
res = 0
call psb_clean_errstack()
end function psb_c_clean_errstack
function psb_c_cdall_vg(ng,vg,ictxt,cdh) bind(c,name='psb_c_cdall_vg') result(res)
implicit none
integer(psb_c_ipk_) :: res
function psb_c_cdall_vg(ng,vg,ictxt,cdh) bind(c,name='psb_c_cdall_vg') result(res)
implicit none
integer(psb_c_ipk_) :: res
integer(psb_c_lpk_), value :: ng
integer(psb_c_ipk_), value :: ictxt
integer(psb_c_ipk_) :: vg(*)
@@ -33,12 +35,12 @@ contains
integer(psb_c_ipk_) :: info
res = -1
if (ng <=0) then
if (ng <=0) then
write(0,*) 'Invalid size'
return
end if
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
call descp%free(info)
if (info == 0) deallocate(descp,stat=info)
@@ -46,32 +48,32 @@ contains
end if
allocate(descp,stat=info)
if (info < 0) return
if (info < 0) return
call psb_cdall(ictxt,descp,info,vg=vg(1:ng))
cdh%item = c_loc(descp)
res = info
end function psb_c_cdall_vg
function psb_c_cdall_vl(nl,vl,ictxt,cdh) bind(c,name='psb_c_cdall_vl') result(res)
implicit none
integer(psb_c_ipk_) :: res
function psb_c_cdall_vl(nl,vl,ictxt,cdh) bind(c,name='psb_c_cdall_vl') result(res)
implicit none
integer(psb_c_ipk_) :: res
integer(psb_c_ipk_), value :: nl, ictxt
integer(psb_c_lpk_) :: vl(*)
type(psb_c_object_type) :: cdh
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info, ixb
integer(psb_c_ipk_) :: info, ixb
res = -1
if (nl <=0) then
if (nl <=0) then
write(0,*) 'Invalid size'
return
end if
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
call descp%free(info)
if (info == 0) deallocate(descp,stat=info)
@@ -79,11 +81,11 @@ contains
end if
allocate(descp,stat=info)
if (info < 0) return
if (info < 0) return
ixb = psb_c_get_index_base()
if (ixb == 1) then
if (ixb == 1) then
call psb_cdall(ictxt,descp,info,vl=vl(1:nl))
else
call psb_cdall(ictxt,descp,info,vl=(vl(1:nl)+(1-ixb)))
@@ -94,21 +96,21 @@ contains
end function psb_c_cdall_vl
function psb_c_cdall_nl(nl,ictxt,cdh) bind(c,name='psb_c_cdall_nl') result(res)
implicit none
implicit none
integer(psb_c_ipk_) :: res
integer(psb_c_ipk_) :: res
integer(psb_c_ipk_), value :: nl, ictxt
type(psb_c_object_type) :: cdh
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info
res = -1
if (nl <=0) then
if (nl <=0) then
write(0,*) 'Invalid size'
return
end if
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
call descp%free(info)
if (info == 0) deallocate(descp,stat=info)
@@ -116,8 +118,8 @@ contains
end if
allocate(descp,stat=info)
if (info < 0) return
if (info < 0) return
call psb_cdall(ictxt,descp,info,nl=nl)
cdh%item = c_loc(descp)
res = info
@@ -125,9 +127,9 @@ contains
end function psb_c_cdall_nl
function psb_c_cdall_repl(n,ictxt,cdh) bind(c,name='psb_c_cdall_repl') result(res)
implicit none
implicit none
integer(psb_c_ipk_) :: res
integer(psb_c_ipk_) :: res
integer(psb_c_lpk_), value :: n
integer(psb_c_ipk_), value :: ictxt
type(psb_c_object_type) :: cdh
@@ -135,12 +137,12 @@ contains
integer(psb_c_ipk_) :: info
res = -1
if (n <=0) then
if (n <=0) then
write(0,*) 'Invalid size'
return
end if
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
call descp%free(info)
if (info == 0) deallocate(descp,stat=info)
@@ -148,25 +150,25 @@ contains
end if
allocate(descp,stat=info)
if (info < 0) return
if (info < 0) return
call psb_cdall(ictxt,descp,info,mg=n,repl=.true.)
cdh%item = c_loc(descp)
res = info
end function psb_c_cdall_repl
function psb_c_cdasb(cdh) bind(c,name='psb_c_cdasb') result(res)
implicit none
integer(psb_c_ipk_) :: res
function psb_c_cdasb(cdh) bind(c,name='psb_c_cdasb') result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: cdh
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
call psb_cdasb(descp,info)
res = info
@@ -177,39 +179,39 @@ contains
function psb_c_cdfree(cdh) bind(c,name='psb_c_cdfree') result(res)
implicit none
integer(psb_c_ipk_) :: res
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: cdh
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
call descp%free(info)
if (info == 0) deallocate(descp,stat=info)
if (info /= 0) return
cdh%item = c_null_ptr
end if
res = info
return
end function psb_c_cdfree
function psb_c_cdins(nz,ia,ja,cdh) bind(c,name='psb_c_cdins') result(res)
implicit none
integer(psb_c_ipk_) :: res
implicit none
integer(psb_c_ipk_) :: res
integer(psb_c_ipk_), value :: nz
type(psb_c_object_type) :: cdh
integer(psb_c_lpk_) :: ia(*),ja(*)
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
call psb_cdins(nz,ia(1:nz),ja(1:nz),descp,info)
res = info
@@ -220,9 +222,9 @@ contains
function psb_c_cd_get_local_rows(cdh) bind(c,name='psb_c_cd_get_local_rows') result(res)
implicit none
implicit none
integer(psb_c_ipk_) :: res
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: cdh
type(psb_desc_type), pointer :: descp
@@ -230,7 +232,7 @@ contains
res = -1
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
res = descp%get_local_rows()
@@ -241,9 +243,9 @@ contains
function psb_c_cd_get_local_cols(cdh) bind(c,name='psb_c_cd_get_local_cols') result(res)
implicit none
implicit none
integer(psb_c_ipk_) :: res
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: cdh
type(psb_desc_type), pointer :: descp
@@ -251,7 +253,7 @@ contains
res = -1
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
res = descp%get_local_cols()
@@ -260,9 +262,9 @@ contains
end function psb_c_cd_get_local_cols
function psb_c_cd_get_global_rows(cdh) bind(c,name='psb_c_cd_get_global_rows') result(res)
implicit none
implicit none
integer(psb_c_lpk_) :: res
integer(psb_c_lpk_) :: res
type(psb_c_object_type) :: cdh
type(psb_desc_type), pointer :: descp
@@ -270,7 +272,7 @@ contains
res = -1
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
res = descp%get_global_rows()
@@ -281,9 +283,9 @@ contains
function psb_c_cd_get_global_cols(cdh) bind(c,name='psb_c_cd_get_global_cols') result(res)
implicit none
implicit none
integer(psb_c_lpk_) :: res
integer(psb_c_lpk_) :: res
type(psb_c_object_type) :: cdh
type(psb_desc_type), pointer :: descp
@@ -291,7 +293,7 @@ contains
res = -1
if (c_associated(cdh%item)) then
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
res = descp%get_global_cols()
@@ -301,4 +303,3 @@ contains
end module psb_base_tools_cbind_mod
cbind/base/psb_c_base.c
+8 -7
View File
@@ -5,7 +5,7 @@
psb_c_descriptor* psb_c_new_descriptor()
{
psb_c_descriptor* temp;
temp=(psb_c_descriptor *) malloc(sizeof(psb_c_descriptor));
temp->descriptor=NULL;
return(temp);
@@ -13,11 +13,11 @@ psb_c_descriptor* psb_c_new_descriptor()
void psb_c_print_errmsg()
{
char *mesg;
{
char *mesg;
for (mesg = psb_c_pop_errmsg(); mesg != NULL; mesg = psb_c_pop_errmsg()) {
fprintf(stderr,"%s\n",mesg);
fprintf(stderr,"%s\n",mesg);
free(mesg);
}
@@ -28,7 +28,7 @@ void psb_c_print_errmsg()
#define PSB_MAX_ERR_LINES 4
static int maxlen=PSB_MAX_ERR_LINES*(PSB_MAX_ERRLINE_LEN+2);
char *psb_c_pop_errmsg()
{
{
char *tmp;
tmp = (char*) malloc(maxlen*sizeof(char));
if (psb_c_f2c_errmsg(tmp,maxlen)<=0) {
@@ -36,4 +36,5 @@ char *psb_c_pop_errmsg()
}
return(tmp);
}
// Convertire il comunicatore fortran in comunicatore c
cbind/base/psb_c_cbase.h
-1
View File
@@ -75,7 +75,6 @@ psb_i_t psb_c_cgeinv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor
psb_i_t psb_c_cgeabs(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *cdh);
psb_i_t psb_c_cgecmp(psb_c_cvector *xh,psb_s_t ch,psb_c_cvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_cgeaddconst(psb_c_cvector *xh,psb_c_t bh,psb_c_cvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_cgescal(psb_c_cvector *xh,psb_s_t ch,psb_c_cvector *zh,psb_c_descriptor *cdh);
psb_s_t psb_c_cgenrm2_weight(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_descriptor *cdh);
psb_s_t psb_c_cgenrm2_weightmask(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_cvector *idvh,psb_c_descriptor *cdh);
#ifdef __cplusplus
cbind/base/psb_c_dbase.h
-1
View File
@@ -75,7 +75,6 @@ psb_i_t psb_c_dgeinv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor
psb_i_t psb_c_dgeabs(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_dgecmp(psb_c_dvector *xh,psb_d_t ch,psb_c_dvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_dgeaddconst(psb_c_dvector *xh,psb_d_t bh,psb_c_dvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_dgescal(psb_c_dvector *xh,psb_d_t ch,psb_c_dvector *zh,psb_c_descriptor *cdh);
psb_d_t psb_c_dgenrm2_weight(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_descriptor *cdh);
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);
cbind/base/psb_c_psblas_cbind_mod.f90
-36
View File
@@ -499,42 +499,6 @@ contains
end function psb_c_cgeaddconst
function psb_c_cgescal(xh,ch,zh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cvector) :: xh,zh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_c_vect_type), pointer :: xp,zp
integer(psb_c_ipk_) :: info
real(c_float_complex) :: ch
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(zh%item)) then
call c_f_pointer(zh%item,zp)
else
return
end if
call psb_gescal(xp,ch,zp,descp,info)
res = info
end function psb_c_cgescal
function psb_c_cgenrm2(xh,cdh) bind(c) result(res)
implicit none
cbind/base/psb_c_sbase.h
-1
View File
@@ -75,7 +75,6 @@ psb_i_t psb_c_sgeinv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor
psb_i_t psb_c_sgeabs(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_sgecmp(psb_c_svector *xh,psb_s_t ch,psb_c_svector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_sgeaddconst(psb_c_svector *xh,psb_s_t bh,psb_c_svector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_sgescal(psb_c_svector *xh,psb_s_t ch,psb_c_svector *zh,psb_c_descriptor *cdh);
psb_s_t psb_c_sgenrm2_weight(psb_c_svector *xh,psb_c_svector *wh,psb_c_descriptor *cdh);
psb_s_t psb_c_sgenrm2_weightmask(psb_c_svector *xh,psb_c_svector *wh,psb_c_svector *idvh,psb_c_descriptor *cdh);
psb_i_t psb_c_smask(psb_c_svector *ch,psb_c_svector *xh,psb_c_svector *mh, bool t, psb_c_descriptor *cdh);
cbind/base/psb_c_zbase.h
-1
View File
@@ -75,7 +75,6 @@ psb_i_t psb_c_zgeinv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor
psb_i_t psb_c_zgeabs(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_zgecmp(psb_c_zvector *xh,psb_d_t ch,psb_c_zvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_zgeaddconst(psb_c_zvector *xh,psb_z_t bh,psb_c_zvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_zgescal(psb_c_zvector *xh,psb_d_t ch,psb_c_zvector *zh,psb_c_descriptor *cdh);
psb_d_t psb_c_zgenrm2_weight(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_descriptor *cdh);
psb_d_t psb_c_zgenrm2_weightmask(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_zvector *idvh,psb_c_descriptor *cdh);
#ifdef __cplusplus
cbind/base/psb_d_psblas_cbind_mod.f90
-36
View File
@@ -499,42 +499,6 @@ contains
end function psb_c_dgeaddconst
function psb_c_dgescal(xh,ch,zh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dvector) :: xh,zh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_d_vect_type), pointer :: xp,zp
integer(psb_c_ipk_) :: info
real(c_double) :: ch
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(zh%item)) then
call c_f_pointer(zh%item,zp)
else
return
end if
call psb_gescal(xp,ch,zp,descp,info)
res = info
end function psb_c_dgescal
function psb_c_dmask(ch,xh,mh,t,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
cbind/base/psb_s_psblas_cbind_mod.f90
-36
View File
@@ -499,42 +499,6 @@ contains
end function psb_c_sgeaddconst
function psb_c_sgescal(xh,ch,zh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_svector) :: xh,zh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_s_vect_type), pointer :: xp,zp
integer(psb_c_ipk_) :: info
real(c_float) :: ch
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(zh%item)) then
call c_f_pointer(zh%item,zp)
else
return
end if
call psb_gescal(xp,ch,zp,descp,info)
res = info
end function psb_c_sgescal
function psb_c_smask(ch,xh,mh,t,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
cbind/base/psb_z_psblas_cbind_mod.f90
-36
View File
@@ -499,42 +499,6 @@ contains
end function psb_c_zgeaddconst
function psb_c_zgescal(xh,ch,zh,cdh) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zvector) :: xh,zh
type(psb_c_descriptor) :: cdh
type(psb_desc_type), pointer :: descp
type(psb_z_vect_type), pointer :: xp,zp
integer(psb_c_ipk_) :: info
real(c_double_complex) :: ch
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(zh%item)) then
call c_f_pointer(zh%item,zp)
else
return
end if
call psb_gescal(xp,ch,zp,descp,info)
res = info
end function psb_c_zgescal
function psb_c_zgenrm2(xh,cdh) bind(c) result(res)
implicit none