#:include "common.fypp"
submodule(stdlib_lapack_base) stdlib_lapack_blas_like_l2
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_slascl( type, kl, ku, cfrom, cto, m, n, a, lda, info )
!! SLASCL multiplies the M by N real matrix A by the real scalar
!! CTO/CFROM. This is done without over/underflow as long as the final
!! result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!! A may be full, upper triangular, lower triangular, upper Hessenberg,
!! or banded.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: zero, half, one
! Scalar Arguments
character, intent(in) :: type
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, lda, m, n
real(sp), intent(in) :: cfrom, cto
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: i, itype, j, k1, k2, k3, k4
real(sp) :: bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( stdlib_lsame( type, 'G' ) ) then
itype = 0_${ik}$
else if( stdlib_lsame( type, 'L' ) ) then
itype = 1_${ik}$
else if( stdlib_lsame( type, 'U' ) ) then
itype = 2_${ik}$
else if( stdlib_lsame( type, 'H' ) ) then
itype = 3_${ik}$
else if( stdlib_lsame( type, 'B' ) ) then
itype = 4_${ik}$
else if( stdlib_lsame( type, 'Q' ) ) then
itype = 5_${ik}$
else if( stdlib_lsame( type, 'Z' ) ) then
itype = 6_${ik}$
else
itype = -1_${ik}$
end if
if( itype==-1_${ik}$ ) then
info = -1_${ik}$
else if( cfrom==zero .or. stdlib${ii}$_sisnan(cfrom) ) then
info = -4_${ik}$
else if( stdlib${ii}$_sisnan(cto) ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -6_${ik}$
else if( n<0_${ik}$ .or. ( itype==4_${ik}$ .and. n/=m ) .or.( itype==5_${ik}$ .and. n/=m ) ) then
info = -7_${ik}$
else if( itype<=3_${ik}$ .and. lda<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
else if( itype>=4_${ik}$ ) then
if( kl<0_${ik}$ .or. kl>max( m-1, 0_${ik}$ ) ) then
info = -2_${ik}$
else if( ku<0_${ik}$ .or. ku>max( n-1, 0_${ik}$ ) .or.( ( itype==4_${ik}$ .or. itype==5_${ik}$ ) .and. kl/=ku ) &
)then
info = -3_${ik}$
else if( ( itype==4_${ik}$ .and. lda<kl+1 ) .or.( itype==5_${ik}$ .and. lda<ku+1 ) .or.( itype==6_${ik}$ &
.and. lda<2_${ik}$*kl+ku+1 ) ) then
info = -9_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLASCL', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 )return
! get machine parameters
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
cfromc = cfrom
ctoc = cto
10 continue
cfrom1 = cfromc*smlnum
if( cfrom1==cfromc ) then
! cfromc is an inf. multiply by a correctly signed zero for
! finite ctoc, or a nan if ctoc is infinite.
mul = ctoc / cfromc
done = .true.
cto1 = ctoc
else
cto1 = ctoc / bignum
if( cto1==ctoc ) then
! ctoc is either 0 or an inf. in both cases, ctoc itself
! serves as the correct multiplication factor.
mul = ctoc
done = .true.
cfromc = one
else if( abs( cfrom1 )>abs( ctoc ) .and. ctoc/=zero ) then
mul = smlnum
done = .false.
cfromc = cfrom1
else if( abs( cto1 )>abs( cfromc ) ) then
mul = bignum
done = .false.
ctoc = cto1
else
mul = ctoc / cfromc
done = .true.
end if
end if
if( itype==0_${ik}$ ) then
! full matrix
do j = 1, n
do i = 1, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==1_${ik}$ ) then
! lower triangular matrix
do j = 1, n
do i = j, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==2_${ik}$ ) then
! upper triangular matrix
do j = 1, n
do i = 1, min( j, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==3_${ik}$ ) then
! upper hessenberg matrix
do j = 1, n
do i = 1, min( j+1, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==4_${ik}$ ) then
! lower half of a symmetric band matrix
k3 = kl + 1_${ik}$
k4 = n + 1_${ik}$
do j = 1, n
do i = 1, min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==5_${ik}$ ) then
! upper half of a symmetric band matrix
k1 = ku + 2_${ik}$
k3 = ku + 1_${ik}$
do j = 1, n
do i = max( k1-j, 1 ), k3
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==6_${ik}$ ) then
! band matrix
k1 = kl + ku + 2_${ik}$
k2 = kl + 1_${ik}$
k3 = 2_${ik}$*kl + ku + 1_${ik}$
k4 = kl + ku + 1_${ik}$ + m
do j = 1, n
do i = max( k1-j, k2 ), min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
end if
if( .not.done )go to 10
return
end subroutine stdlib${ii}$_slascl
pure module subroutine stdlib${ii}$_dlascl( type, kl, ku, cfrom, cto, m, n, a, lda, info )
!! DLASCL multiplies the M by N real matrix A by the real scalar
!! CTO/CFROM. This is done without over/underflow as long as the final
!! result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!! A may be full, upper triangular, lower triangular, upper Hessenberg,
!! or banded.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: zero, half, one
! Scalar Arguments
character, intent(in) :: type
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, lda, m, n
real(dp), intent(in) :: cfrom, cto
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: i, itype, j, k1, k2, k3, k4
real(dp) :: bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( stdlib_lsame( type, 'G' ) ) then
itype = 0_${ik}$
else if( stdlib_lsame( type, 'L' ) ) then
itype = 1_${ik}$
else if( stdlib_lsame( type, 'U' ) ) then
itype = 2_${ik}$
else if( stdlib_lsame( type, 'H' ) ) then
itype = 3_${ik}$
else if( stdlib_lsame( type, 'B' ) ) then
itype = 4_${ik}$
else if( stdlib_lsame( type, 'Q' ) ) then
itype = 5_${ik}$
else if( stdlib_lsame( type, 'Z' ) ) then
itype = 6_${ik}$
else
itype = -1_${ik}$
end if
if( itype==-1_${ik}$ ) then
info = -1_${ik}$
else if( cfrom==zero .or. stdlib${ii}$_disnan(cfrom) ) then
info = -4_${ik}$
else if( stdlib${ii}$_disnan(cto) ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -6_${ik}$
else if( n<0_${ik}$ .or. ( itype==4_${ik}$ .and. n/=m ) .or.( itype==5_${ik}$ .and. n/=m ) ) then
info = -7_${ik}$
else if( itype<=3_${ik}$ .and. lda<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
else if( itype>=4_${ik}$ ) then
if( kl<0_${ik}$ .or. kl>max( m-1, 0_${ik}$ ) ) then
info = -2_${ik}$
else if( ku<0_${ik}$ .or. ku>max( n-1, 0_${ik}$ ) .or.( ( itype==4_${ik}$ .or. itype==5_${ik}$ ) .and. kl/=ku ) &
)then
info = -3_${ik}$
else if( ( itype==4_${ik}$ .and. lda<kl+1 ) .or.( itype==5_${ik}$ .and. lda<ku+1 ) .or.( itype==6_${ik}$ &
.and. lda<2_${ik}$*kl+ku+1 ) ) then
info = -9_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLASCL', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 )return
! get machine parameters
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
cfromc = cfrom
ctoc = cto
10 continue
cfrom1 = cfromc*smlnum
if( cfrom1==cfromc ) then
! cfromc is an inf. multiply by a correctly signed zero for
! finite ctoc, or a nan if ctoc is infinite.
mul = ctoc / cfromc
done = .true.
cto1 = ctoc
else
cto1 = ctoc / bignum
if( cto1==ctoc ) then
! ctoc is either 0 or an inf. in both cases, ctoc itself
! serves as the correct multiplication factor.
mul = ctoc
done = .true.
cfromc = one
else if( abs( cfrom1 )>abs( ctoc ) .and. ctoc/=zero ) then
mul = smlnum
done = .false.
cfromc = cfrom1
else if( abs( cto1 )>abs( cfromc ) ) then
mul = bignum
done = .false.
ctoc = cto1
else
mul = ctoc / cfromc
done = .true.
end if
end if
if( itype==0_${ik}$ ) then
! full matrix
do j = 1, n
do i = 1, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==1_${ik}$ ) then
! lower triangular matrix
do j = 1, n
do i = j, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==2_${ik}$ ) then
! upper triangular matrix
do j = 1, n
do i = 1, min( j, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==3_${ik}$ ) then
! upper hessenberg matrix
do j = 1, n
do i = 1, min( j+1, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==4_${ik}$ ) then
! lower half of a symmetric band matrix
k3 = kl + 1_${ik}$
k4 = n + 1_${ik}$
do j = 1, n
do i = 1, min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==5_${ik}$ ) then
! upper half of a symmetric band matrix
k1 = ku + 2_${ik}$
k3 = ku + 1_${ik}$
do j = 1, n
do i = max( k1-j, 1 ), k3
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==6_${ik}$ ) then
! band matrix
k1 = kl + ku + 2_${ik}$
k2 = kl + 1_${ik}$
k3 = 2_${ik}$*kl + ku + 1_${ik}$
k4 = kl + ku + 1_${ik}$ + m
do j = 1, n
do i = max( k1-j, k2 ), min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
end if
if( .not.done )go to 10
return
end subroutine stdlib${ii}$_dlascl
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lascl( type, kl, ku, cfrom, cto, m, n, a, lda, info )
!! DLASCL: multiplies the M by N real matrix A by the real scalar
!! CTO/CFROM. This is done without over/underflow as long as the final
!! result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!! A may be full, upper triangular, lower triangular, upper Hessenberg,
!! or banded.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: zero, half, one
! Scalar Arguments
character, intent(in) :: type
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, lda, m, n
real(${rk}$), intent(in) :: cfrom, cto
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: i, itype, j, k1, k2, k3, k4
real(${rk}$) :: bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( stdlib_lsame( type, 'G' ) ) then
itype = 0_${ik}$
else if( stdlib_lsame( type, 'L' ) ) then
itype = 1_${ik}$
else if( stdlib_lsame( type, 'U' ) ) then
itype = 2_${ik}$
else if( stdlib_lsame( type, 'H' ) ) then
itype = 3_${ik}$
else if( stdlib_lsame( type, 'B' ) ) then
itype = 4_${ik}$
else if( stdlib_lsame( type, 'Q' ) ) then
itype = 5_${ik}$
else if( stdlib_lsame( type, 'Z' ) ) then
itype = 6_${ik}$
else
itype = -1_${ik}$
end if
if( itype==-1_${ik}$ ) then
info = -1_${ik}$
else if( cfrom==zero .or. stdlib${ii}$_${ri}$isnan(cfrom) ) then
info = -4_${ik}$
else if( stdlib${ii}$_${ri}$isnan(cto) ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -6_${ik}$
else if( n<0_${ik}$ .or. ( itype==4_${ik}$ .and. n/=m ) .or.( itype==5_${ik}$ .and. n/=m ) ) then
info = -7_${ik}$
else if( itype<=3_${ik}$ .and. lda<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
else if( itype>=4_${ik}$ ) then
if( kl<0_${ik}$ .or. kl>max( m-1, 0_${ik}$ ) ) then
info = -2_${ik}$
else if( ku<0_${ik}$ .or. ku>max( n-1, 0_${ik}$ ) .or.( ( itype==4_${ik}$ .or. itype==5_${ik}$ ) .and. kl/=ku ) &
)then
info = -3_${ik}$
else if( ( itype==4_${ik}$ .and. lda<kl+1 ) .or.( itype==5_${ik}$ .and. lda<ku+1 ) .or.( itype==6_${ik}$ &
.and. lda<2_${ik}$*kl+ku+1 ) ) then
info = -9_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLASCL', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 )return
! get machine parameters
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
cfromc = cfrom
ctoc = cto
10 continue
cfrom1 = cfromc*smlnum
if( cfrom1==cfromc ) then
! cfromc is an inf. multiply by a correctly signed zero for
! finite ctoc, or a nan if ctoc is infinite.
mul = ctoc / cfromc
done = .true.
cto1 = ctoc
else
cto1 = ctoc / bignum
if( cto1==ctoc ) then
! ctoc is either 0 or an inf. in both cases, ctoc itself
! serves as the correct multiplication factor.
mul = ctoc
done = .true.
cfromc = one
else if( abs( cfrom1 )>abs( ctoc ) .and. ctoc/=zero ) then
mul = smlnum
done = .false.
cfromc = cfrom1
else if( abs( cto1 )>abs( cfromc ) ) then
mul = bignum
done = .false.
ctoc = cto1
else
mul = ctoc / cfromc
done = .true.
end if
end if
if( itype==0_${ik}$ ) then
! full matrix
do j = 1, n
do i = 1, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==1_${ik}$ ) then
! lower triangular matrix
do j = 1, n
do i = j, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==2_${ik}$ ) then
! upper triangular matrix
do j = 1, n
do i = 1, min( j, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==3_${ik}$ ) then
! upper hessenberg matrix
do j = 1, n
do i = 1, min( j+1, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==4_${ik}$ ) then
! lower half of a symmetric band matrix
k3 = kl + 1_${ik}$
k4 = n + 1_${ik}$
do j = 1, n
do i = 1, min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==5_${ik}$ ) then
! upper half of a symmetric band matrix
k1 = ku + 2_${ik}$
k3 = ku + 1_${ik}$
do j = 1, n
do i = max( k1-j, 1 ), k3
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==6_${ik}$ ) then
! band matrix
k1 = kl + ku + 2_${ik}$
k2 = kl + 1_${ik}$
k3 = 2_${ik}$*kl + ku + 1_${ik}$
k4 = kl + ku + 1_${ik}$ + m
do j = 1, n
do i = max( k1-j, k2 ), min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
end if
if( .not.done )go to 10
return
end subroutine stdlib${ii}$_${ri}$lascl
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clascl( type, kl, ku, cfrom, cto, m, n, a, lda, info )
!! CLASCL multiplies the M by N complex matrix A by the real scalar
!! CTO/CFROM. This is done without over/underflow as long as the final
!! result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!! A may be full, upper triangular, lower triangular, upper Hessenberg,
!! or banded.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: zero, half, one
! Scalar Arguments
character, intent(in) :: type
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, lda, m, n
real(sp), intent(in) :: cfrom, cto
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: i, itype, j, k1, k2, k3, k4
real(sp) :: bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( stdlib_lsame( type, 'G' ) ) then
itype = 0_${ik}$
else if( stdlib_lsame( type, 'L' ) ) then
itype = 1_${ik}$
else if( stdlib_lsame( type, 'U' ) ) then
itype = 2_${ik}$
else if( stdlib_lsame( type, 'H' ) ) then
itype = 3_${ik}$
else if( stdlib_lsame( type, 'B' ) ) then
itype = 4_${ik}$
else if( stdlib_lsame( type, 'Q' ) ) then
itype = 5_${ik}$
else if( stdlib_lsame( type, 'Z' ) ) then
itype = 6_${ik}$
else
itype = -1_${ik}$
end if
if( itype==-1_${ik}$ ) then
info = -1_${ik}$
else if( cfrom==zero .or. stdlib${ii}$_sisnan(cfrom) ) then
info = -4_${ik}$
else if( stdlib${ii}$_sisnan(cto) ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -6_${ik}$
else if( n<0_${ik}$ .or. ( itype==4_${ik}$ .and. n/=m ) .or.( itype==5_${ik}$ .and. n/=m ) ) then
info = -7_${ik}$
else if( itype<=3_${ik}$ .and. lda<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
else if( itype>=4_${ik}$ ) then
if( kl<0_${ik}$ .or. kl>max( m-1, 0_${ik}$ ) ) then
info = -2_${ik}$
else if( ku<0_${ik}$ .or. ku>max( n-1, 0_${ik}$ ) .or.( ( itype==4_${ik}$ .or. itype==5_${ik}$ ) .and. kl/=ku ) &
)then
info = -3_${ik}$
else if( ( itype==4_${ik}$ .and. lda<kl+1 ) .or.( itype==5_${ik}$ .and. lda<ku+1 ) .or.( itype==6_${ik}$ &
.and. lda<2_${ik}$*kl+ku+1 ) ) then
info = -9_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLASCL', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 )return
! get machine parameters
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
cfromc = cfrom
ctoc = cto
10 continue
cfrom1 = cfromc*smlnum
if( cfrom1==cfromc ) then
! cfromc is an inf. multiply by a correctly signed zero for
! finite ctoc, or a nan if ctoc is infinite.
mul = ctoc / cfromc
done = .true.
cto1 = ctoc
else
cto1 = ctoc / bignum
if( cto1==ctoc ) then
! ctoc is either 0 or an inf. in both cases, ctoc itself
! serves as the correct multiplication factor.
mul = ctoc
done = .true.
cfromc = one
else if( abs( cfrom1 )>abs( ctoc ) .and. ctoc/=zero ) then
mul = smlnum
done = .false.
cfromc = cfrom1
else if( abs( cto1 )>abs( cfromc ) ) then
mul = bignum
done = .false.
ctoc = cto1
else
mul = ctoc / cfromc
done = .true.
end if
end if
if( itype==0_${ik}$ ) then
! full matrix
do j = 1, n
do i = 1, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==1_${ik}$ ) then
! lower triangular matrix
do j = 1, n
do i = j, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==2_${ik}$ ) then
! upper triangular matrix
do j = 1, n
do i = 1, min( j, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==3_${ik}$ ) then
! upper hessenberg matrix
do j = 1, n
do i = 1, min( j+1, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==4_${ik}$ ) then
! lower chalf of a symmetric band matrix
k3 = kl + 1_${ik}$
k4 = n + 1_${ik}$
do j = 1, n
do i = 1, min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==5_${ik}$ ) then
! upper chalf of a symmetric band matrix
k1 = ku + 2_${ik}$
k3 = ku + 1_${ik}$
do j = 1, n
do i = max( k1-j, 1 ), k3
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==6_${ik}$ ) then
! band matrix
k1 = kl + ku + 2_${ik}$
k2 = kl + 1_${ik}$
k3 = 2_${ik}$*kl + ku + 1_${ik}$
k4 = kl + ku + 1_${ik}$ + m
do j = 1, n
do i = max( k1-j, k2 ), min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
end if
if( .not.done )go to 10
return
end subroutine stdlib${ii}$_clascl
pure module subroutine stdlib${ii}$_zlascl( type, kl, ku, cfrom, cto, m, n, a, lda, info )
!! ZLASCL multiplies the M by N complex matrix A by the real scalar
!! CTO/CFROM. This is done without over/underflow as long as the final
!! result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!! A may be full, upper triangular, lower triangular, upper Hessenberg,
!! or banded.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: zero, half, one
! Scalar Arguments
character, intent(in) :: type
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, lda, m, n
real(dp), intent(in) :: cfrom, cto
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: i, itype, j, k1, k2, k3, k4
real(dp) :: bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( stdlib_lsame( type, 'G' ) ) then
itype = 0_${ik}$
else if( stdlib_lsame( type, 'L' ) ) then
itype = 1_${ik}$
else if( stdlib_lsame( type, 'U' ) ) then
itype = 2_${ik}$
else if( stdlib_lsame( type, 'H' ) ) then
itype = 3_${ik}$
else if( stdlib_lsame( type, 'B' ) ) then
itype = 4_${ik}$
else if( stdlib_lsame( type, 'Q' ) ) then
itype = 5_${ik}$
else if( stdlib_lsame( type, 'Z' ) ) then
itype = 6_${ik}$
else
itype = -1_${ik}$
end if
if( itype==-1_${ik}$ ) then
info = -1_${ik}$
else if( cfrom==zero .or. stdlib${ii}$_disnan(cfrom) ) then
info = -4_${ik}$
else if( stdlib${ii}$_disnan(cto) ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -6_${ik}$
else if( n<0_${ik}$ .or. ( itype==4_${ik}$ .and. n/=m ) .or.( itype==5_${ik}$ .and. n/=m ) ) then
info = -7_${ik}$
else if( itype<=3_${ik}$ .and. lda<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
else if( itype>=4_${ik}$ ) then
if( kl<0_${ik}$ .or. kl>max( m-1, 0_${ik}$ ) ) then
info = -2_${ik}$
else if( ku<0_${ik}$ .or. ku>max( n-1, 0_${ik}$ ) .or.( ( itype==4_${ik}$ .or. itype==5_${ik}$ ) .and. kl/=ku ) &
)then
info = -3_${ik}$
else if( ( itype==4_${ik}$ .and. lda<kl+1 ) .or.( itype==5_${ik}$ .and. lda<ku+1 ) .or.( itype==6_${ik}$ &
.and. lda<2_${ik}$*kl+ku+1 ) ) then
info = -9_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLASCL', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 )return
! get machine parameters
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
cfromc = cfrom
ctoc = cto
10 continue
cfrom1 = cfromc*smlnum
if( cfrom1==cfromc ) then
! cfromc is an inf. multiply by a correctly signed zero for
! finite ctoc, or a nan if ctoc is infinite.
mul = ctoc / cfromc
done = .true.
cto1 = ctoc
else
cto1 = ctoc / bignum
if( cto1==ctoc ) then
! ctoc is either 0 or an inf. in both cases, ctoc itself
! serves as the correct multiplication factor.
mul = ctoc
done = .true.
cfromc = one
else if( abs( cfrom1 )>abs( ctoc ) .and. ctoc/=zero ) then
mul = smlnum
done = .false.
cfromc = cfrom1
else if( abs( cto1 )>abs( cfromc ) ) then
mul = bignum
done = .false.
ctoc = cto1
else
mul = ctoc / cfromc
done = .true.
end if
end if
if( itype==0_${ik}$ ) then
! full matrix
do j = 1, n
do i = 1, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==1_${ik}$ ) then
! lower triangular matrix
do j = 1, n
do i = j, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==2_${ik}$ ) then
! upper triangular matrix
do j = 1, n
do i = 1, min( j, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==3_${ik}$ ) then
! upper hessenberg matrix
do j = 1, n
do i = 1, min( j+1, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==4_${ik}$ ) then
! lower chalf of a symmetric band matrix
k3 = kl + 1_${ik}$
k4 = n + 1_${ik}$
do j = 1, n
do i = 1, min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==5_${ik}$ ) then
! upper chalf of a symmetric band matrix
k1 = ku + 2_${ik}$
k3 = ku + 1_${ik}$
do j = 1, n
do i = max( k1-j, 1 ), k3
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==6_${ik}$ ) then
! band matrix
k1 = kl + ku + 2_${ik}$
k2 = kl + 1_${ik}$
k3 = 2_${ik}$*kl + ku + 1_${ik}$
k4 = kl + ku + 1_${ik}$ + m
do j = 1, n
do i = max( k1-j, k2 ), min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
end if
if( .not.done )go to 10
return
end subroutine stdlib${ii}$_zlascl
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lascl( type, kl, ku, cfrom, cto, m, n, a, lda, info )
!! ZLASCL: multiplies the M by N complex matrix A by the real scalar
!! CTO/CFROM. This is done without over/underflow as long as the final
!! result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!! A may be full, upper triangular, lower triangular, upper Hessenberg,
!! or banded.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: zero, half, one
! Scalar Arguments
character, intent(in) :: type
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, lda, m, n
real(${ck}$), intent(in) :: cfrom, cto
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: i, itype, j, k1, k2, k3, k4
real(${ck}$) :: bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( stdlib_lsame( type, 'G' ) ) then
itype = 0_${ik}$
else if( stdlib_lsame( type, 'L' ) ) then
itype = 1_${ik}$
else if( stdlib_lsame( type, 'U' ) ) then
itype = 2_${ik}$
else if( stdlib_lsame( type, 'H' ) ) then
itype = 3_${ik}$
else if( stdlib_lsame( type, 'B' ) ) then
itype = 4_${ik}$
else if( stdlib_lsame( type, 'Q' ) ) then
itype = 5_${ik}$
else if( stdlib_lsame( type, 'Z' ) ) then
itype = 6_${ik}$
else
itype = -1_${ik}$
end if
if( itype==-1_${ik}$ ) then
info = -1_${ik}$
else if( cfrom==zero .or. stdlib${ii}$_${c2ri(ci)}$isnan(cfrom) ) then
info = -4_${ik}$
else if( stdlib${ii}$_${c2ri(ci)}$isnan(cto) ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -6_${ik}$
else if( n<0_${ik}$ .or. ( itype==4_${ik}$ .and. n/=m ) .or.( itype==5_${ik}$ .and. n/=m ) ) then
info = -7_${ik}$
else if( itype<=3_${ik}$ .and. lda<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
else if( itype>=4_${ik}$ ) then
if( kl<0_${ik}$ .or. kl>max( m-1, 0_${ik}$ ) ) then
info = -2_${ik}$
else if( ku<0_${ik}$ .or. ku>max( n-1, 0_${ik}$ ) .or.( ( itype==4_${ik}$ .or. itype==5_${ik}$ ) .and. kl/=ku ) &
)then
info = -3_${ik}$
else if( ( itype==4_${ik}$ .and. lda<kl+1 ) .or.( itype==5_${ik}$ .and. lda<ku+1 ) .or.( itype==6_${ik}$ &
.and. lda<2_${ik}$*kl+ku+1 ) ) then
info = -9_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLASCL', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 )return
! get machine parameters
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
cfromc = cfrom
ctoc = cto
10 continue
cfrom1 = cfromc*smlnum
if( cfrom1==cfromc ) then
! cfromc is an inf. multiply by a correctly signed zero for
! finite ctoc, or a nan if ctoc is infinite.
mul = ctoc / cfromc
done = .true.
cto1 = ctoc
else
cto1 = ctoc / bignum
if( cto1==ctoc ) then
! ctoc is either 0 or an inf. in both cases, ctoc itself
! serves as the correct multiplication factor.
mul = ctoc
done = .true.
cfromc = one
else if( abs( cfrom1 )>abs( ctoc ) .and. ctoc/=zero ) then
mul = smlnum
done = .false.
cfromc = cfrom1
else if( abs( cto1 )>abs( cfromc ) ) then
mul = bignum
done = .false.
ctoc = cto1
else
mul = ctoc / cfromc
done = .true.
end if
end if
if( itype==0_${ik}$ ) then
! full matrix
do j = 1, n
do i = 1, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==1_${ik}$ ) then
! lower triangular matrix
do j = 1, n
do i = j, m
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==2_${ik}$ ) then
! upper triangular matrix
do j = 1, n
do i = 1, min( j, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==3_${ik}$ ) then
! upper hessenberg matrix
do j = 1, n
do i = 1, min( j+1, m )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==4_${ik}$ ) then
! lower chalf of a symmetric band matrix
k3 = kl + 1_${ik}$
k4 = n + 1_${ik}$
do j = 1, n
do i = 1, min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==5_${ik}$ ) then
! upper chalf of a symmetric band matrix
k1 = ku + 2_${ik}$
k3 = ku + 1_${ik}$
do j = 1, n
do i = max( k1-j, 1 ), k3
a( i, j ) = a( i, j )*mul
end do
end do
else if( itype==6_${ik}$ ) then
! band matrix
k1 = kl + ku + 2_${ik}$
k2 = kl + 1_${ik}$
k3 = 2_${ik}$*kl + ku + 1_${ik}$
k4 = kl + ku + 1_${ik}$ + m
do j = 1, n
do i = max( k1-j, k2 ), min( k3, k4-j )
a( i, j ) = a( i, j )*mul
end do
end do
end if
if( .not.done )go to 10
return
end subroutine stdlib${ii}$_${ci}$lascl
#:endif
#:endfor
module subroutine stdlib${ii}$_sla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy )
!! SLA_GEAMV performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n, trans
! Array Arguments
real(sp), intent(in) :: a(lda,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(sp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' )) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( lda<max( 1_${ik}$, m ) )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'SLA_GEAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, lenx
temp = abs( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, lenx
temp = abs( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = 1, lenx
temp = abs( a( i, j ) )
symb_zero = symb_zero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if (.not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = 1, lenx
temp = abs( a( j, i ) )
symb_zero = symb_zero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if (.not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_sla_geamv
module subroutine stdlib${ii}$_dla_geamv ( trans, m, n, alpha, a, lda, x, incx, beta,y, incy )
!! DLA_GEAMV performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n, trans
! Array Arguments
real(dp), intent(in) :: a(lda,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(dp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' )) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( lda<max( 1_${ik}$, m ) )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'DLA_GEAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, lenx
temp = abs( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, lenx
temp = abs( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = 1, lenx
temp = abs( a( i, j ) )
symb_zero = symb_zero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if (.not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = 1, lenx
temp = abs( a( j, i ) )
symb_zero = symb_zero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if (.not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_dla_geamv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$la_geamv ( trans, m, n, alpha, a, lda, x, incx, beta,y, incy )
!! DLA_GEAMV: performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${rk}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n, trans
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), x(*)
real(${rk}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_wero
real(${rk}$) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' )) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( lda<max( 1_${ik}$, m ) )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'DLA_GEAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_wero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, lenx
temp = abs( a( i, j ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, lenx
temp = abs( a( j, i ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = 1, lenx
temp = abs( a( i, j ) )
symb_wero = symb_wero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if (.not.symb_wero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = 1, lenx
temp = abs( a( j, i ) )
symb_wero = symb_wero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if (.not.symb_wero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$la_geamv
#:endif
#:endfor
module subroutine stdlib${ii}$_cla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy )
!! CLA_GEAMV performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
integer(${ik}$), intent(in) :: trans
! Array Arguments
complex(sp), intent(in) :: a(lda,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(sp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny
complex(sp) :: cdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( lda<max( 1_${ik}$, m ) )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'CLA_GEAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==czero ).and.( beta==cone ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == 0.0_sp ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == 0.0_sp ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= 0.0_sp ) then
do j = 1, lenx
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_zero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == 0.0_sp ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == 0.0_sp ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= 0.0_sp ) then
do j = 1, lenx
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_zero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == 0.0_sp ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == 0.0_sp ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= 0.0_sp ) then
jx = kx
do j = 1, lenx
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == 0.0_sp ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == 0.0_sp ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= 0.0_sp ) then
jx = kx
do j = 1, lenx
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_cla_geamv
module subroutine stdlib${ii}$_zla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy )
!! ZLA_GEAMV performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
integer(${ik}$), intent(in) :: trans
! Array Arguments
complex(dp), intent(in) :: a(lda,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(dp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny
complex(dp) :: cdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( lda<max( 1_${ik}$, m ) )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'ZLA_GEAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==czero ).and.( beta==cone ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == czero ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
do j = 1, lenx
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_zero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == czero ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
do j = 1, lenx
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_zero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == czero ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
jx = kx
do j = 1, lenx
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == czero ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
jx = kx
do j = 1, lenx
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_zla_geamv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$la_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy )
!! ZLA_GEAMV: performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${ck}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
integer(${ik}$), intent(in) :: trans
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), x(*)
real(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_wero
real(${ck}$) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny
complex(${ck}$) :: cdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( lda<max( 1_${ik}$, m ) )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'ZLA_GEAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==czero ).and.( beta==cone ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_wero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == czero ) then
symb_wero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
do j = 1, lenx
temp = cabs1( a( i, j ) )
symb_wero = symb_wero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_wero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == czero ) then
symb_wero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
do j = 1, lenx
temp = cabs1( a( j, i ) )
symb_wero = symb_wero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_wero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == czero ) then
symb_wero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
jx = kx
do j = 1, lenx
temp = cabs1( a( i, j ) )
symb_wero = symb_wero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_wero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == czero ) then
symb_wero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
jx = kx
do j = 1, lenx
temp = cabs1( a( j, i ) )
symb_wero = symb_wero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_wero ) y( iy ) =y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$la_geamv
#:endif
#:endfor
module subroutine stdlib${ii}$_sla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy )
!! SLA_GBAMV performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans
! Array Arguments
real(sp), intent(in) :: ab(ldab,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(sp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( kl<0_${ik}$ .or. kl>m-1 ) then
info = 4_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = 5_${ik}$
else if( ldab<kl+ku+1 )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'SLA_GBAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( kd+i-j, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( ke-i+j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( kd+i-j, j ) )
symb_zero = symb_zero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( ke-i+j, i ) )
symb_zero = symb_zero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_sla_gbamv
module subroutine stdlib${ii}$_dla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy )
!! DLA_GBAMV performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans
! Array Arguments
real(dp), intent(in) :: ab(ldab,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(dp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( kl<0_${ik}$ .or. kl>m-1 ) then
info = 4_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = 5_${ik}$
else if( ldab<kl+ku+1 )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'DLA_GBAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( kd+i-j, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( ke-i+j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( kd+i-j, j ) )
symb_zero = symb_zero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( ke-i+j, i ) )
symb_zero = symb_zero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_dla_gbamv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$la_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy )
!! DLA_GBAMV: performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${rk}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*), x(*)
real(${rk}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_wero
real(${rk}$) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( kl<0_${ik}$ .or. kl>m-1 ) then
info = 4_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = 5_${ik}$
else if( ldab<kl+ku+1 )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'DLA_GBAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_wero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( kd+i-j, j ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( ke-i+j, i ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( kd+i-j, j ) )
symb_wero = symb_wero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = abs( ab( ke-i+j, i ) )
symb_wero = symb_wero .and.( x( jx ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$la_gbamv
#:endif
#:endfor
module subroutine stdlib${ii}$_cla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy )
!! CLA_GBAMV performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans
! Array Arguments
complex(sp), intent(in) :: ab(ldab,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(sp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke
complex(sp) :: cdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( kl<0_${ik}$ .or. kl>m-1 ) then
info = 4_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = 5_${ik}$
else if( ldab<kl+ku+1 )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'CLA_GBAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==czero ).and.( beta==cone ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == 0.0_sp ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == 0.0_sp ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= 0.0_sp ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( kd+i-j, j ) )
symb_zero = symb_zero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == 0.0_sp ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == 0.0_sp ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= 0.0_sp ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( ke-i+j, i ) )
symb_zero = symb_zero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == 0.0_sp ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == 0.0_sp ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= 0.0_sp ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( kd+i-j, j ) )
symb_zero = symb_zero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == 0.0_sp ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == 0.0_sp ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= 0.0_sp ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( ke-i+j, i ) )
symb_zero = symb_zero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_cla_gbamv
module subroutine stdlib${ii}$_zla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy )
!! ZLA_GBAMV performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans
! Array Arguments
complex(dp), intent(in) :: ab(ldab,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(dp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke
complex(dp) :: cdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( kl<0_${ik}$ .or. kl>m-1 ) then
info = 4_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = 5_${ik}$
else if( ldab<kl+ku+1 )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'ZLA_GBAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==czero ).and.( beta==cone ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == czero ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( kd+i-j, j ) )
symb_zero = symb_zero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == czero ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( ke-i+j, i ) )
symb_zero = symb_zero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == czero ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( kd+i-j, j ) )
symb_zero = symb_zero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == czero ) then
symb_zero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( ke-i+j, i ) )
symb_zero = symb_zero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_zla_gbamv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$la_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy )
!! ZLA_GBAMV: performs one of the matrix-vector operations
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${ck}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans
! Array Arguments
complex(${ck}$), intent(in) :: ab(ldab,*), x(*)
real(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_wero
real(${ck}$) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke
complex(${ck}$) :: cdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )&
.or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then
info = 1_${ik}$
else if( m<0_${ik}$ )then
info = 2_${ik}$
else if( n<0_${ik}$ )then
info = 3_${ik}$
else if( kl<0_${ik}$ .or. kl>m-1 ) then
info = 4_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = 5_${ik}$
else if( ldab<kl+ku+1 )then
info = 6_${ik}$
else if( incx==0_${ik}$ )then
info = 8_${ik}$
else if( incy==0_${ik}$ )then
info = 11_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'ZLA_GBAMV ', info )
return
end if
! quick return if possible.
if( ( m==0 ).or.( n==0 ).or.( ( alpha==czero ).and.( beta==cone ) ) )return
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(m*n) symb_wero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
iy = ky
if ( incx==1_${ik}$ ) then
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == czero ) then
symb_wero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( kd+i-j, j ) )
symb_wero = symb_wero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_wero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == czero ) then
symb_wero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( ke-i+j, i ) )
symb_wero = symb_wero .and.( x( j ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if ( .not.symb_wero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if( trans==stdlib${ii}$_ilatrans( 'N' ) )then
do i = 1, leny
if ( beta == czero ) then
symb_wero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( kd+i-j, j ) )
symb_wero = symb_wero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, leny
if ( beta == czero ) then
symb_wero = .true.
y( iy ) = czero
else if ( y( iy ) == czero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= czero ) then
jx = kx
do j = max( i-kl, 1 ), min( i+ku, lenx )
temp = cabs1( ab( ke-i+j, i ) )
symb_wero = symb_wero .and.( x( jx ) == czero .or. temp == czero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$la_gbamv
#:endif
#:endfor
module subroutine stdlib${ii}$_cla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy )
!! CLA_SYAMV performs the matrix-vector operation
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! n by n symmetric matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n, uplo
! Array Arguments
complex(sp), intent(in) :: a(lda,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(sp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky
complex(sp) :: zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag ( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( uplo/=stdlib${ii}$_ilauplo( 'U' ) .and.uplo/=stdlib${ii}$_ilauplo( 'L' ) )then
info = 1_${ik}$
else if( n<0_${ik}$ )then
info = 2_${ik}$
else if( lda<max( 1_${ik}$, n ) )then
info = 5_${ik}$
else if( incx==0_${ik}$ )then
info = 7_${ik}$
else if( incy==0_${ik}$ )then
info = 10_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'CHEMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(n^2) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if ( uplo == stdlib${ii}$_ilauplo( 'U' ) ) then
do i = 1, n
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
do j = i+1, n
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if (.not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, n
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
do j = i+1, n
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if (.not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if ( uplo == stdlib${ii}$_ilauplo( 'U' ) ) then
do i = 1, n
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
jx = kx
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
do j = i+1, n
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, n
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
jx = kx
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
do j = i+1, n
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_cla_heamv
module subroutine stdlib${ii}$_zla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy )
!! ZLA_SYAMV performs the matrix-vector operation
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! n by n symmetric matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n, uplo
! Array Arguments
complex(dp), intent(in) :: a(lda,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_zero
real(dp) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky
complex(dp) :: zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag ( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( uplo/=stdlib${ii}$_ilauplo( 'U' ) .and.uplo/=stdlib${ii}$_ilauplo( 'L' ) )then
info = 1_${ik}$
else if( n<0_${ik}$ )then
info = 2_${ik}$
else if( lda<max( 1_${ik}$, n ) )then
info = 5_${ik}$
else if( incx==0_${ik}$ )then
info = 7_${ik}$
else if( incy==0_${ik}$ )then
info = 10_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'ZHEMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(n^2) symb_zero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if ( uplo == stdlib${ii}$_ilauplo( 'U' ) ) then
do i = 1, n
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
do j = i+1, n
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if (.not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, n
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
do j = i+1, n
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if (.not.symb_zero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if ( uplo == stdlib${ii}$_ilauplo( 'U' ) ) then
do i = 1, n
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
jx = kx
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
do j = i+1, n
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, n
if ( beta == zero ) then
symb_zero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_zero = .true.
else
symb_zero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
jx = kx
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( i, j ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
do j = i+1, n
temp = cabs1( a( j, i ) )
symb_zero = symb_zero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_zero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_zla_heamv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$la_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy )
!! ZLA_SYAMV performs the matrix-vector operation
!! y := alpha*abs(A)*abs(x) + beta*abs(y),
!! where alpha and beta are scalars, x and y are vectors and A is an
!! n by n symmetric matrix.
!! This function is primarily used in calculating error bounds.
!! To protect against underflow during evaluation, components in
!! the resulting vector are perturbed away from zero by (N+1)
!! times the underflow threshold. To prevent unnecessarily large
!! errors for block-structure embedded in general matrices,
!! "symbolically" zero components are not perturbed. A zero
!! entry is considered "symbolic" if all multiplications involved
!! in computing that entry have at least one zero multiplicand.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${ck}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n, uplo
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), x(*)
real(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
logical(lk) :: symb_wero
real(${ck}$) :: temp, safe1
integer(${ik}$) :: i, info, iy, j, jx, kx, ky
complex(${ck}$) :: zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag ( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( uplo/=stdlib${ii}$_ilauplo( 'U' ) .and.uplo/=stdlib${ii}$_ilauplo( 'L' ) )then
info = 1_${ik}$
else if( n<0_${ik}$ )then
info = 2_${ik}$
else if( lda<max( 1_${ik}$, n ) )then
info = 5_${ik}$
else if( incx==0_${ik}$ )then
info = 7_${ik}$
else if( incy==0_${ik}$ )then
info = 10_${ik}$
end if
if( info/=0_${ik}$ )then
call stdlib${ii}$_xerbla( 'ZHEMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ).or.( ( alpha==zero ).and.( beta==one ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ )then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n - 1_${ik}$ )*incx
end if
if( incy>0_${ik}$ )then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n - 1_${ik}$ )*incy
end if
! set safe1 essentially to be the underflow threshold times the
! number of additions in each row.
safe1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = (n+1)*safe1
! form y := alpha*abs(a)*abs(x) + beta*abs(y).
! the o(n^2) symb_wero tests could be replaced by o(n) queries to
! the inexact flag. still doesn't help change the iteration order
! to per-column.
iy = ky
if ( incx==1_${ik}$ ) then
if ( uplo == stdlib${ii}$_ilauplo( 'U' ) ) then
do i = 1, n
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( j, i ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
do j = i+1, n
temp = cabs1( a( i, j ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if (.not.symb_wero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, n
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( i, j ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
do j = i+1, n
temp = cabs1( a( j, i ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
end do
end if
if (.not.symb_wero)y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
else
if ( uplo == stdlib${ii}$_ilauplo( 'U' ) ) then
do i = 1, n
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
jx = kx
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( j, i ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
do j = i+1, n
temp = cabs1( a( i, j ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
else
do i = 1, n
if ( beta == zero ) then
symb_wero = .true.
y( iy ) = zero
else if ( y( iy ) == zero ) then
symb_wero = .true.
else
symb_wero = .false.
y( iy ) = beta * abs( y( iy ) )
end if
jx = kx
if ( alpha /= zero ) then
do j = 1, i
temp = cabs1( a( i, j ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
do j = i+1, n
temp = cabs1( a( j, i ) )
symb_wero = symb_wero .and.( x( j ) == zero .or. temp == zero )
y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
jx = jx + incx
end do
end if
if ( .not.symb_wero )y( iy ) = y( iy ) + sign( safe1, y( iy ) )
iy = iy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$la_heamv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sla_wwaddw( n, x, y, w )
!! SLA_WWADDW adds a vector W into a doubled-single vector (X, Y).
!! This works for all extant IBM's hex and binary floating point
!! arithmetic, but not for decimal.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(inout) :: x(*), y(*)
real(sp), intent(in) :: w(*)
! =====================================================================
! Local Scalars
real(sp) :: s
integer(${ik}$) :: i
! Executable Statements
do 10 i = 1, n
s = x(i) + w(i)
s = (s + s) - s
y(i) = ((x(i) - s) + w(i)) + y(i)
x(i) = s
10 continue
return
end subroutine stdlib${ii}$_sla_wwaddw
pure module subroutine stdlib${ii}$_dla_wwaddw( n, x, y, w )
!! DLA_WWADDW adds a vector W into a doubled-single vector (X, Y).
!! This works for all extant IBM's hex and binary floating point
!! arithmetic, but not for decimal.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(inout) :: x(*), y(*)
real(dp), intent(in) :: w(*)
! =====================================================================
! Local Scalars
real(dp) :: s
integer(${ik}$) :: i
! Executable Statements
do 10 i = 1, n
s = x(i) + w(i)
s = (s + s) - s
y(i) = ((x(i) - s) + w(i)) + y(i)
x(i) = s
10 continue
return
end subroutine stdlib${ii}$_dla_wwaddw
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$la_wwaddw( n, x, y, w )
!! DLA_WWADDW: adds a vector W into a doubled-single vector (X, Y).
!! This works for all extant IBM's hex and binary floating point
!! arithmetic, but not for decimal.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(inout) :: x(*), y(*)
real(${rk}$), intent(in) :: w(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: s
integer(${ik}$) :: i
! Executable Statements
do 10 i = 1, n
s = x(i) + w(i)
s = (s + s) - s
y(i) = ((x(i) - s) + w(i)) + y(i)
x(i) = s
10 continue
return
end subroutine stdlib${ii}$_${ri}$la_wwaddw
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cla_wwaddw( n, x, y, w )
!! CLA_WWADDW adds a vector W into a doubled-single vector (X, Y).
!! This works for all extant IBM's hex and binary floating point
!! arithmetic, but not for decimal.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(sp), intent(inout) :: x(*), y(*)
complex(sp), intent(in) :: w(*)
! =====================================================================
! Local Scalars
complex(sp) :: s
integer(${ik}$) :: i
! Executable Statements
do 10 i = 1, n
s = x(i) + w(i)
s = (s + s) - s
y(i) = ((x(i) - s) + w(i)) + y(i)
x(i) = s
10 continue
return
end subroutine stdlib${ii}$_cla_wwaddw
pure module subroutine stdlib${ii}$_zla_wwaddw( n, x, y, w )
!! ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y).
!! This works for all extant IBM's hex and binary floating point
!! arithmetic, but not for decimal.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(dp), intent(inout) :: x(*), y(*)
complex(dp), intent(in) :: w(*)
! =====================================================================
! Local Scalars
complex(dp) :: s
integer(${ik}$) :: i
! Executable Statements
do 10 i = 1, n
s = x(i) + w(i)
s = (s + s) - s
y(i) = ((x(i) - s) + w(i)) + y(i)
x(i) = s
10 continue
return
end subroutine stdlib${ii}$_zla_wwaddw
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$la_wwaddw( n, x, y, w )
!! ZLA_WWADDW: adds a vector W into a doubled-single vector (X, Y).
!! This works for all extant IBM's hex and binary floating point
!! arithmetic, but not for decimal.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(${ck}$), intent(inout) :: x(*), y(*)
complex(${ck}$), intent(in) :: w(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: s
integer(${ik}$) :: i
! Executable Statements
do 10 i = 1, n
s = x(i) + w(i)
s = (s + s) - s
y(i) = ((x(i) - s) + w(i)) + y(i)
x(i) = s
10 continue
return
end subroutine stdlib${ii}$_${ci}$la_wwaddw
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cspmv( uplo, n, alpha, ap, x, incx, beta, y, incy )
!! CSPMV performs the matrix-vector operation
!! y := alpha*A*x + beta*y,
!! where alpha and beta are scalars, x and y are n element vectors and
!! A is an n by n symmetric matrix, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, incy, n
complex(sp), intent(in) :: alpha, beta
! Array Arguments
complex(sp), intent(in) :: ap(*), x(*)
complex(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
complex(sp) :: temp1, temp2
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 6_${ik}$
else if( incy==0_${ik}$ ) then
info = 9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSPMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( ( alpha==czero ) .and. ( beta==cone ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ ) then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n-1 )*incx
end if
if( incy>0_${ik}$ ) then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n-1 )*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
! first form y := beta*y.
if( beta/=cone ) then
if( incy==1_${ik}$ ) then
if( beta==czero ) then
do i = 1, n
y( i ) = czero
end do
else
do i = 1, n
y( i ) = beta*y( i )
end do
end if
else
iy = ky
if( beta==czero ) then
do i = 1, n
y( iy ) = czero
iy = iy + incy
end do
else
do i = 1, n
y( iy ) = beta*y( iy )
iy = iy + incy
end do
end if
end if
end if
if( alpha==czero )return
kk = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! form y when ap contains the upper triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
k = kk
do i = 1, j - 1
y( i ) = y( i ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( i )
k = k + 1_${ik}$
end do
y( j ) = y( j ) + temp1*ap( kk+j-1 ) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
ix = kx
iy = ky
do k = kk, kk + j - 2
y( iy ) = y( iy ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( ix )
ix = ix + incx
iy = iy + incy
end do
y( jy ) = y( jy ) + temp1*ap( kk+j-1 ) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
y( j ) = y( j ) + temp1*ap( kk )
k = kk + 1_${ik}$
do i = j + 1, n
y( i ) = y( i ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( i )
k = k + 1_${ik}$
end do
y( j ) = y( j ) + alpha*temp2
kk = kk + ( n-j+1 )
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
y( jy ) = y( jy ) + temp1*ap( kk )
ix = jx
iy = jy
do k = kk + 1, kk + n - j
ix = ix + incx
iy = iy + incy
y( iy ) = y( iy ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( ix )
end do
y( jy ) = y( jy ) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + ( n-j+1 )
end do
end if
end if
return
end subroutine stdlib${ii}$_cspmv
pure module subroutine stdlib${ii}$_zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy )
!! ZSPMV performs the matrix-vector operation
!! y := alpha*A*x + beta*y,
!! where alpha and beta are scalars, x and y are n element vectors and
!! A is an n by n symmetric matrix, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, incy, n
complex(dp), intent(in) :: alpha, beta
! Array Arguments
complex(dp), intent(in) :: ap(*), x(*)
complex(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
complex(dp) :: temp1, temp2
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 6_${ik}$
else if( incy==0_${ik}$ ) then
info = 9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( ( alpha==czero ) .and. ( beta==cone ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ ) then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n-1 )*incx
end if
if( incy>0_${ik}$ ) then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n-1 )*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
! first form y := beta*y.
if( beta/=cone ) then
if( incy==1_${ik}$ ) then
if( beta==czero ) then
do i = 1, n
y( i ) = czero
end do
else
do i = 1, n
y( i ) = beta*y( i )
end do
end if
else
iy = ky
if( beta==czero ) then
do i = 1, n
y( iy ) = czero
iy = iy + incy
end do
else
do i = 1, n
y( iy ) = beta*y( iy )
iy = iy + incy
end do
end if
end if
end if
if( alpha==czero )return
kk = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! form y when ap contains the upper triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
k = kk
do i = 1, j - 1
y( i ) = y( i ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( i )
k = k + 1_${ik}$
end do
y( j ) = y( j ) + temp1*ap( kk+j-1 ) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
ix = kx
iy = ky
do k = kk, kk + j - 2
y( iy ) = y( iy ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( ix )
ix = ix + incx
iy = iy + incy
end do
y( jy ) = y( jy ) + temp1*ap( kk+j-1 ) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
y( j ) = y( j ) + temp1*ap( kk )
k = kk + 1_${ik}$
do i = j + 1, n
y( i ) = y( i ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( i )
k = k + 1_${ik}$
end do
y( j ) = y( j ) + alpha*temp2
kk = kk + ( n-j+1 )
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
y( jy ) = y( jy ) + temp1*ap( kk )
ix = jx
iy = jy
do k = kk + 1, kk + n - j
ix = ix + incx
iy = iy + incy
y( iy ) = y( iy ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( ix )
end do
y( jy ) = y( jy ) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + ( n-j+1 )
end do
end if
end if
return
end subroutine stdlib${ii}$_zspmv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$spmv( uplo, n, alpha, ap, x, incx, beta, y, incy )
!! ZSPMV: performs the matrix-vector operation
!! y := alpha*A*x + beta*y,
!! where alpha and beta are scalars, x and y are n element vectors and
!! A is an n by n symmetric matrix, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, incy, n
complex(${ck}$), intent(in) :: alpha, beta
! Array Arguments
complex(${ck}$), intent(in) :: ap(*), x(*)
complex(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
complex(${ck}$) :: temp1, temp2
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 6_${ik}$
else if( incy==0_${ik}$ ) then
info = 9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( ( alpha==czero ) .and. ( beta==cone ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ ) then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n-1 )*incx
end if
if( incy>0_${ik}$ ) then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n-1 )*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
! first form y := beta*y.
if( beta/=cone ) then
if( incy==1_${ik}$ ) then
if( beta==czero ) then
do i = 1, n
y( i ) = czero
end do
else
do i = 1, n
y( i ) = beta*y( i )
end do
end if
else
iy = ky
if( beta==czero ) then
do i = 1, n
y( iy ) = czero
iy = iy + incy
end do
else
do i = 1, n
y( iy ) = beta*y( iy )
iy = iy + incy
end do
end if
end if
end if
if( alpha==czero )return
kk = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! form y when ap contains the upper triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
k = kk
do i = 1, j - 1
y( i ) = y( i ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( i )
k = k + 1_${ik}$
end do
y( j ) = y( j ) + temp1*ap( kk+j-1 ) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
ix = kx
iy = ky
do k = kk, kk + j - 2
y( iy ) = y( iy ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( ix )
ix = ix + incx
iy = iy + incy
end do
y( jy ) = y( jy ) + temp1*ap( kk+j-1 ) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
y( j ) = y( j ) + temp1*ap( kk )
k = kk + 1_${ik}$
do i = j + 1, n
y( i ) = y( i ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( i )
k = k + 1_${ik}$
end do
y( j ) = y( j ) + alpha*temp2
kk = kk + ( n-j+1 )
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
y( jy ) = y( jy ) + temp1*ap( kk )
ix = jx
iy = jy
do k = kk + 1, kk + n - j
ix = ix + incx
iy = iy + incy
y( iy ) = y( iy ) + temp1*ap( k )
temp2 = temp2 + ap( k )*x( ix )
end do
y( jy ) = y( jy ) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + ( n-j+1 )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$spmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cspr( uplo, n, alpha, x, incx, ap )
!! CSPR performs the symmetric rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a complex scalar, x is an n element vector and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, n
complex(sp), intent(in) :: alpha
! Array Arguments
complex(sp), intent(inout) :: ap(*)
complex(sp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
complex(sp) :: temp
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSPR ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( alpha==czero ) )return
! set the start point in x if the increment is not unity.
if( incx<=0_${ik}$ ) then
kx = 1_${ik}$ - ( n-1 )*incx
else if( incx/=1_${ik}$ ) then
kx = 1_${ik}$
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
kk = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! form a when upper triangle is stored in ap.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
k = kk
do i = 1, j - 1
ap( k ) = ap( k ) + x( i )*temp
k = k + 1_${ik}$
end do
ap( kk+j-1 ) = ap( kk+j-1 ) + x( j )*temp
else
ap( kk+j-1 ) = ap( kk+j-1 )
end if
kk = kk + j
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = kx
do k = kk, kk + j - 2
ap( k ) = ap( k ) + x( ix )*temp
ix = ix + incx
end do
ap( kk+j-1 ) = ap( kk+j-1 ) + x( jx )*temp
else
ap( kk+j-1 ) = ap( kk+j-1 )
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
ap( kk ) = ap( kk ) + temp*x( j )
k = kk + 1_${ik}$
do i = j + 1, n
ap( k ) = ap( k ) + x( i )*temp
k = k + 1_${ik}$
end do
else
ap( kk ) = ap( kk )
end if
kk = kk + n - j + 1_${ik}$
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ap( kk ) = ap( kk ) + temp*x( jx )
ix = jx
do k = kk + 1, kk + n - j
ix = ix + incx
ap( k ) = ap( k ) + x( ix )*temp
end do
else
ap( kk ) = ap( kk )
end if
jx = jx + incx
kk = kk + n - j + 1_${ik}$
end do
end if
end if
return
end subroutine stdlib${ii}$_cspr
pure module subroutine stdlib${ii}$_zspr( uplo, n, alpha, x, incx, ap )
!! ZSPR performs the symmetric rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a complex scalar, x is an n element vector and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, n
complex(dp), intent(in) :: alpha
! Array Arguments
complex(dp), intent(inout) :: ap(*)
complex(dp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
complex(dp) :: temp
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPR ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( alpha==czero ) )return
! set the start point in x if the increment is not unity.
if( incx<=0_${ik}$ ) then
kx = 1_${ik}$ - ( n-1 )*incx
else if( incx/=1_${ik}$ ) then
kx = 1_${ik}$
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
kk = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! form a when upper triangle is stored in ap.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
k = kk
do i = 1, j - 1
ap( k ) = ap( k ) + x( i )*temp
k = k + 1_${ik}$
end do
ap( kk+j-1 ) = ap( kk+j-1 ) + x( j )*temp
else
ap( kk+j-1 ) = ap( kk+j-1 )
end if
kk = kk + j
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = kx
do k = kk, kk + j - 2
ap( k ) = ap( k ) + x( ix )*temp
ix = ix + incx
end do
ap( kk+j-1 ) = ap( kk+j-1 ) + x( jx )*temp
else
ap( kk+j-1 ) = ap( kk+j-1 )
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
ap( kk ) = ap( kk ) + temp*x( j )
k = kk + 1_${ik}$
do i = j + 1, n
ap( k ) = ap( k ) + x( i )*temp
k = k + 1_${ik}$
end do
else
ap( kk ) = ap( kk )
end if
kk = kk + n - j + 1_${ik}$
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ap( kk ) = ap( kk ) + temp*x( jx )
ix = jx
do k = kk + 1, kk + n - j
ix = ix + incx
ap( k ) = ap( k ) + x( ix )*temp
end do
else
ap( kk ) = ap( kk )
end if
jx = jx + incx
kk = kk + n - j + 1_${ik}$
end do
end if
end if
return
end subroutine stdlib${ii}$_zspr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$spr( uplo, n, alpha, x, incx, ap )
!! ZSPR: performs the symmetric rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a complex scalar, x is an n element vector and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, n
complex(${ck}$), intent(in) :: alpha
! Array Arguments
complex(${ck}$), intent(inout) :: ap(*)
complex(${ck}$), intent(in) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
complex(${ck}$) :: temp
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPR ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( alpha==czero ) )return
! set the start point in x if the increment is not unity.
if( incx<=0_${ik}$ ) then
kx = 1_${ik}$ - ( n-1 )*incx
else if( incx/=1_${ik}$ ) then
kx = 1_${ik}$
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
kk = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! form a when upper triangle is stored in ap.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
k = kk
do i = 1, j - 1
ap( k ) = ap( k ) + x( i )*temp
k = k + 1_${ik}$
end do
ap( kk+j-1 ) = ap( kk+j-1 ) + x( j )*temp
else
ap( kk+j-1 ) = ap( kk+j-1 )
end if
kk = kk + j
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = kx
do k = kk, kk + j - 2
ap( k ) = ap( k ) + x( ix )*temp
ix = ix + incx
end do
ap( kk+j-1 ) = ap( kk+j-1 ) + x( jx )*temp
else
ap( kk+j-1 ) = ap( kk+j-1 )
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
ap( kk ) = ap( kk ) + temp*x( j )
k = kk + 1_${ik}$
do i = j + 1, n
ap( k ) = ap( k ) + x( i )*temp
k = k + 1_${ik}$
end do
else
ap( kk ) = ap( kk )
end if
kk = kk + n - j + 1_${ik}$
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ap( kk ) = ap( kk ) + temp*x( jx )
ix = jx
do k = kk + 1, kk + n - j
ix = ix + incx
ap( k ) = ap( k ) + x( ix )*temp
end do
else
ap( kk ) = ap( kk )
end if
jx = jx + incx
kk = kk + n - j + 1_${ik}$
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$spr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy )
!! CSYMV performs the matrix-vector operation
!! y := alpha*A*x + beta*y,
!! where alpha and beta are scalars, x and y are n element vectors and
!! A is an n by n symmetric matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, incy, lda, n
complex(sp), intent(in) :: alpha, beta
! Array Arguments
complex(sp), intent(in) :: a(lda,*), x(*)
complex(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
complex(sp) :: temp1, temp2
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = 5_${ik}$
else if( incx==0_${ik}$ ) then
info = 7_${ik}$
else if( incy==0_${ik}$ ) then
info = 10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( ( alpha==czero ) .and. ( beta==cone ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ ) then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n-1 )*incx
end if
if( incy>0_${ik}$ ) then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n-1 )*incy
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through the triangular part
! of a.
! first form y := beta*y.
if( beta/=cone ) then
if( incy==1_${ik}$ ) then
if( beta==czero ) then
do i = 1, n
y( i ) = czero
end do
else
do i = 1, n
y( i ) = beta*y( i )
end do
end if
else
iy = ky
if( beta==czero ) then
do i = 1, n
y( iy ) = czero
iy = iy + incy
end do
else
do i = 1, n
y( iy ) = beta*y( iy )
iy = iy + incy
end do
end if
end if
end if
if( alpha==czero )return
if( stdlib_lsame( uplo, 'U' ) ) then
! form y when a is stored in upper triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
do i = 1, j - 1
y( i ) = y( i ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( i )
end do
y( j ) = y( j ) + temp1*a( j, j ) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
ix = kx
iy = ky
do i = 1, j - 1
y( iy ) = y( iy ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( ix )
ix = ix + incx
iy = iy + incy
end do
y( jy ) = y( jy ) + temp1*a( j, j ) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
y( j ) = y( j ) + temp1*a( j, j )
do i = j + 1, n
y( i ) = y( i ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( i )
end do
y( j ) = y( j ) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
y( jy ) = y( jy ) + temp1*a( j, j )
ix = jx
iy = jy
do i = j + 1, n
ix = ix + incx
iy = iy + incy
y( iy ) = y( iy ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( ix )
end do
y( jy ) = y( jy ) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_csymv
pure module subroutine stdlib${ii}$_zsymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy )
!! ZSYMV performs the matrix-vector operation
!! y := alpha*A*x + beta*y,
!! where alpha and beta are scalars, x and y are n element vectors and
!! A is an n by n symmetric matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, incy, lda, n
complex(dp), intent(in) :: alpha, beta
! Array Arguments
complex(dp), intent(in) :: a(lda,*), x(*)
complex(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
complex(dp) :: temp1, temp2
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = 5_${ik}$
else if( incx==0_${ik}$ ) then
info = 7_${ik}$
else if( incy==0_${ik}$ ) then
info = 10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( ( alpha==czero ) .and. ( beta==cone ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ ) then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n-1 )*incx
end if
if( incy>0_${ik}$ ) then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n-1 )*incy
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through the triangular part
! of a.
! first form y := beta*y.
if( beta/=cone ) then
if( incy==1_${ik}$ ) then
if( beta==czero ) then
do i = 1, n
y( i ) = czero
end do
else
do i = 1, n
y( i ) = beta*y( i )
end do
end if
else
iy = ky
if( beta==czero ) then
do i = 1, n
y( iy ) = czero
iy = iy + incy
end do
else
do i = 1, n
y( iy ) = beta*y( iy )
iy = iy + incy
end do
end if
end if
end if
if( alpha==czero )return
if( stdlib_lsame( uplo, 'U' ) ) then
! form y when a is stored in upper triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
do i = 1, j - 1
y( i ) = y( i ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( i )
end do
y( j ) = y( j ) + temp1*a( j, j ) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
ix = kx
iy = ky
do i = 1, j - 1
y( iy ) = y( iy ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( ix )
ix = ix + incx
iy = iy + incy
end do
y( jy ) = y( jy ) + temp1*a( j, j ) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
y( j ) = y( j ) + temp1*a( j, j )
do i = j + 1, n
y( i ) = y( i ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( i )
end do
y( j ) = y( j ) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
y( jy ) = y( jy ) + temp1*a( j, j )
ix = jx
iy = jy
do i = j + 1, n
ix = ix + incx
iy = iy + incy
y( iy ) = y( iy ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( ix )
end do
y( jy ) = y( jy ) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_zsymv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$symv( uplo, n, alpha, a, lda, x, incx, beta, y, incy )
!! ZSYMV: performs the matrix-vector operation
!! y := alpha*A*x + beta*y,
!! where alpha and beta are scalars, x and y are n element vectors and
!! A is an n by n symmetric matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, incy, lda, n
complex(${ck}$), intent(in) :: alpha, beta
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), x(*)
complex(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
complex(${ck}$) :: temp1, temp2
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = 5_${ik}$
else if( incx==0_${ik}$ ) then
info = 7_${ik}$
else if( incy==0_${ik}$ ) then
info = 10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYMV ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( ( alpha==czero ) .and. ( beta==cone ) ) )return
! set up the start points in x and y.
if( incx>0_${ik}$ ) then
kx = 1_${ik}$
else
kx = 1_${ik}$ - ( n-1 )*incx
end if
if( incy>0_${ik}$ ) then
ky = 1_${ik}$
else
ky = 1_${ik}$ - ( n-1 )*incy
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through the triangular part
! of a.
! first form y := beta*y.
if( beta/=cone ) then
if( incy==1_${ik}$ ) then
if( beta==czero ) then
do i = 1, n
y( i ) = czero
end do
else
do i = 1, n
y( i ) = beta*y( i )
end do
end if
else
iy = ky
if( beta==czero ) then
do i = 1, n
y( iy ) = czero
iy = iy + incy
end do
else
do i = 1, n
y( iy ) = beta*y( iy )
iy = iy + incy
end do
end if
end if
end if
if( alpha==czero )return
if( stdlib_lsame( uplo, 'U' ) ) then
! form y when a is stored in upper triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
do i = 1, j - 1
y( i ) = y( i ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( i )
end do
y( j ) = y( j ) + temp1*a( j, j ) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
ix = kx
iy = ky
do i = 1, j - 1
y( iy ) = y( iy ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( ix )
ix = ix + incx
iy = iy + incy
end do
y( jy ) = y( jy ) + temp1*a( j, j ) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then
do j = 1, n
temp1 = alpha*x( j )
temp2 = czero
y( j ) = y( j ) + temp1*a( j, j )
do i = j + 1, n
y( i ) = y( i ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( i )
end do
y( j ) = y( j ) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1, n
temp1 = alpha*x( jx )
temp2 = czero
y( jy ) = y( jy ) + temp1*a( j, j )
ix = jx
iy = jy
do i = j + 1, n
ix = ix + incx
iy = iy + incy
y( iy ) = y( iy ) + temp1*a( i, j )
temp2 = temp2 + a( i, j )*x( ix )
end do
y( jy ) = y( jy ) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$symv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csyr( uplo, n, alpha, x, incx, a, lda )
!! CSYR performs the symmetric rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a complex scalar, x is an n element vector and A is an
!! n by n symmetric matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, lda, n
complex(sp), intent(in) :: alpha
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, j, jx, kx
complex(sp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = 7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYR ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( alpha==czero ) )return
! set the start point in x if the increment is not unity.
if( incx<=0_${ik}$ ) then
kx = 1_${ik}$ - ( n-1 )*incx
else if( incx/=1_${ik}$ ) then
kx = 1_${ik}$
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through the triangular part
! of a.
if( stdlib_lsame( uplo, 'U' ) ) then
! form a when a is stored in upper triangle.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
do i = 1, j
a( i, j ) = a( i, j ) + x( i )*temp
end do
end if
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = kx
do i = 1, j
a( i, j ) = a( i, j ) + x( ix )*temp
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
else
! form a when a is stored in lower triangle.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
do i = j, n
a( i, j ) = a( i, j ) + x( i )*temp
end do
end if
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = jx
do i = j, n
a( i, j ) = a( i, j ) + x( ix )*temp
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_csyr
pure module subroutine stdlib${ii}$_zsyr( uplo, n, alpha, x, incx, a, lda )
!! ZSYR performs the symmetric rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a complex scalar, x is an n element vector and A is an
!! n by n symmetric matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, lda, n
complex(dp), intent(in) :: alpha
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, j, jx, kx
complex(dp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = 7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYR ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( alpha==czero ) )return
! set the start point in x if the increment is not unity.
if( incx<=0_${ik}$ ) then
kx = 1_${ik}$ - ( n-1 )*incx
else if( incx/=1_${ik}$ ) then
kx = 1_${ik}$
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through the triangular part
! of a.
if( stdlib_lsame( uplo, 'U' ) ) then
! form a when a is stored in upper triangle.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
do i = 1, j
a( i, j ) = a( i, j ) + x( i )*temp
end do
end if
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = kx
do i = 1, j
a( i, j ) = a( i, j ) + x( ix )*temp
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
else
! form a when a is stored in lower triangle.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
do i = j, n
a( i, j ) = a( i, j ) + x( i )*temp
end do
end if
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = jx
do i = j, n
a( i, j ) = a( i, j ) + x( ix )*temp
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_zsyr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$syr( uplo, n, alpha, x, incx, a, lda )
!! ZSYR: performs the symmetric rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a complex scalar, x is an n element vector and A is an
!! n by n symmetric matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incx, lda, n
complex(${ck}$), intent(in) :: alpha
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(in) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, info, ix, j, jx, kx
complex(${ck}$) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = 1_${ik}$
else if( n<0_${ik}$ ) then
info = 2_${ik}$
else if( incx==0_${ik}$ ) then
info = 5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = 7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYR ', info )
return
end if
! quick return if possible.
if( ( n==0 ) .or. ( alpha==czero ) )return
! set the start point in x if the increment is not unity.
if( incx<=0_${ik}$ ) then
kx = 1_${ik}$ - ( n-1 )*incx
else if( incx/=1_${ik}$ ) then
kx = 1_${ik}$
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through the triangular part
! of a.
if( stdlib_lsame( uplo, 'U' ) ) then
! form a when a is stored in upper triangle.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
do i = 1, j
a( i, j ) = a( i, j ) + x( i )*temp
end do
end if
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = kx
do i = 1, j
a( i, j ) = a( i, j ) + x( ix )*temp
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
else
! form a when a is stored in lower triangle.
if( incx==1_${ik}$ ) then
do j = 1, n
if( x( j )/=czero ) then
temp = alpha*x( j )
do i = j, n
a( i, j ) = a( i, j ) + x( i )*temp
end do
end if
end do
else
jx = kx
do j = 1, n
if( x( jx )/=czero ) then
temp = alpha*x( jx )
ix = jx
do i = j, n
a( i, j ) = a( i, j ) + x( ix )*temp
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$syr
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_blas_like_l2
