#:include "common.fypp"
submodule(stdlib_lapack_solve) stdlib_lapack_solve_ldl_comp2
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_ssptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! SSPTRS solves a system of linear equations A*X = B with a real
!! symmetric matrix A stored in packed format using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(in) :: ap(*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
real(sp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_sger( k-1, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_sscal( nrhs, one / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_sger( k-2, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_sger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, 1_${ik}$ &
), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
1_${ik}$ ), ldb )
call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1_${ik}$, one, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_sger( n-k, nrhs, -one, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+1,&
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_sscal( nrhs, one / ap( kc ), b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_sswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_sger( n-k-1, nrhs, -one, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ )&
, ldb )
call stdlib${ii}$_sger( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / akm1k
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( &
kc+1 ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ), &
1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
k ) ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_ssptrs
pure module subroutine stdlib${ii}$_dsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! DSPTRS solves a system of linear equations A*X = B with a real
!! symmetric matrix A stored in packed format using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(in) :: ap(*)
real(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
real(dp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_dger( k-1, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_dscal( nrhs, one / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_dger( k-2, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_dger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, 1_${ik}$ &
), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
1_${ik}$ ), ldb )
call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1_${ik}$, one, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_dger( n-k, nrhs, -one, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+1,&
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_dscal( nrhs, one / ap( kc ), b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_dswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_dger( n-k-1, nrhs, -one, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ )&
, ldb )
call stdlib${ii}$_dger( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / akm1k
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( &
kc+1 ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ), &
1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
k ) ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_dsptrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! DSPTRS: solves a system of linear equations A*X = B with a real
!! symmetric matrix A stored in packed format using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
real(${rk}$) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_${ri}$ger( k-1, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_${ri}$scal( nrhs, one / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_${ri}$ger( k-2, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ri}$ger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, 1_${ik}$ &
), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
1_${ik}$ ), ldb )
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1_${ik}$, one, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ri}$ger( n-k, nrhs, -one, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+1,&
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_${ri}$scal( nrhs, one / ap( kc ), b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_${ri}$ger( n-k-1, nrhs, -one, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ )&
, ldb )
call stdlib${ii}$_${ri}$ger( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / akm1k
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( &
kc+1 ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ), &
1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
k ) ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_${ri}$sptrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! CSPTRS solves a system of linear equations A*X = B with a complex
!! symmetric matrix A stored in packed format using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by CSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: ap(*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_cgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_cscal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( &
k+1, 1_${ik}$ ), ldb )
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_cgeru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_cscal( nrhs, cone / ap( kc ), b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_cgeru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_cgeru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / akm1k
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( &
kc+1 ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ),&
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
k ) ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_csptrs
pure module subroutine stdlib${ii}$_zsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! ZSPTRS solves a system of linear equations A*X = B with a complex
!! symmetric matrix A stored in packed format using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: ap(*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_zgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_zscal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( &
k+1, 1_${ik}$ ), ldb )
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_zgeru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_zscal( nrhs, cone / ap( kc ), b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_zgeru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_zgeru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / akm1k
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( &
kc+1 ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ),&
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
k ) ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_zsptrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! ZSPTRS: solves a system of linear equations A*X = B with a complex
!! symmetric matrix A stored in packed format using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: ap(*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_${ci}$scal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( &
k+1, 1_${ik}$ ), ldb )
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ci}$geru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_${ci}$scal( nrhs, cone / ap( kc ), b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_${ci}$geru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$geru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / akm1k
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( &
kc+1 ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ),&
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
k ) ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_${ci}$sptrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssptri( uplo, n, ap, ipiv, work, info )
!! SSPTRI computes the inverse of a real symmetric indefinite matrix
!! A in packed storage using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by SSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(inout) :: ap(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
real(sp) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==zero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==zero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = one / ap( kc+k-1 )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_scopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+k-1 ) )
ak = ap( kc+k-1 ) / t
akp1 = ap( kcnext+k ) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-one )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_scopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_sdot( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_scopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_sswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = ap( kc+j-1 )
ap( kc+j-1 ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = one / ap( kc )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_scopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_sspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1_${ik}$,zero, ap( kc+1 ), &
1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_sdot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+1 ) )
ak = ap( kcnext ) / t
akp1 = ap( kc ) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-one )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_scopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_sspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( kc+&
1_${ik}$ ), 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_sdot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_sdot( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+2 &
), 1_${ik}$ )
call stdlib${ii}$_scopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_sspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_sdot( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_sswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = ap( kc+j-k )
ap( kc+j-k ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_ssptri
pure module subroutine stdlib${ii}$_dsptri( uplo, n, ap, ipiv, work, info )
!! DSPTRI computes the inverse of a real symmetric indefinite matrix
!! A in packed storage using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by DSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(inout) :: ap(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
real(dp) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==zero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==zero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = one / ap( kc+k-1 )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_dcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+k-1 ) )
ak = ap( kc+k-1 ) / t
akp1 = ap( kcnext+k ) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-one )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_dcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_ddot( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_dcopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_dswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = ap( kc+j-1 )
ap( kc+j-1 ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = one / ap( kc )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_dcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1_${ik}$,zero, ap( kc+1 ), &
1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_ddot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+1 ) )
ak = ap( kcnext ) / t
akp1 = ap( kc ) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-one )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_dcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( kc+&
1_${ik}$ ), 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_ddot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_ddot( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+2 &
), 1_${ik}$ )
call stdlib${ii}$_dcopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_ddot( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_dswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = ap( kc+j-k )
ap( kc+j-k ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_dsptri
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sptri( uplo, n, ap, ipiv, work, info )
!! DSPTRI: computes the inverse of a real symmetric indefinite matrix
!! A in packed storage using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by DSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(inout) :: ap(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
real(${rk}$) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==zero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==zero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = one / ap( kc+k-1 )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ri}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$spmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+k-1 ) )
ak = ap( kc+k-1 ) / t
akp1 = ap( kcnext+k ) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-one )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ri}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$spmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_${ri}$dot( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_${ri}$copy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$spmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_${ri}$swap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = ap( kc+j-1 )
ap( kc+j-1 ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = one / ap( kc )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ri}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$spmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1_${ik}$,zero, ap( kc+1 ), &
1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+1 ) )
ak = ap( kcnext ) / t
akp1 = ap( kc ) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-one )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ri}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$spmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( kc+&
1_${ik}$ ), 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_${ri}$dot( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+2 &
), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$spmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = ap( kc+j-k )
ap( kc+j-k ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_${ri}$sptri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csptri( uplo, n, ap, ipiv, work, info )
!! CSPTRI computes the inverse of a complex symmetric indefinite matrix
!! A in packed storage using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by CSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: ap(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
complex(sp) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = cone / ap( kc+k-1 )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = ap( kcnext+k-1 )
ak = ap( kc+k-1 ) / t
akp1 = ap( kcnext+k ) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-cone )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_cdotu( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_ccopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_cswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = ap( kc+j-1 )
ap( kc+j-1 ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = cone / ap( kc )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_ccopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cspmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
, 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = ap( kcnext+1 )
ak = ap( kcnext ) / t
akp1 = ap( kc ) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-cone )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_ccopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cspmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
kc+1 ), 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_cdotu( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
2_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_ccopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cspmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_cswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = ap( kc+j-k )
ap( kc+j-k ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_csptri
pure module subroutine stdlib${ii}$_zsptri( uplo, n, ap, ipiv, work, info )
!! ZSPTRI computes the inverse of a complex symmetric indefinite matrix
!! A in packed storage using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by ZSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: ap(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
complex(dp) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = cone / ap( kc+k-1 )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = ap( kcnext+k-1 )
ak = ap( kc+k-1 ) / t
akp1 = ap( kcnext+k ) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-cone )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_zdotu( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_zcopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_zswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = ap( kc+j-1 )
ap( kc+j-1 ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = cone / ap( kc )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_zcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zspmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
, 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = ap( kcnext+1 )
ak = ap( kcnext ) / t
akp1 = ap( kc ) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-cone )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_zcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zspmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
kc+1 ), 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_zdotu( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
2_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_zcopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zspmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_zswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = ap( kc+j-k )
ap( kc+j-k ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_zsptri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sptri( uplo, n, ap, ipiv, work, info )
!! ZSPTRI: computes the inverse of a complex symmetric indefinite matrix
!! A in packed storage using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by ZSPTRF.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: ap(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
complex(${ck}$) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = cone / ap( kc+k-1 )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = ap( kcnext+k-1 )
ak = ap( kc+k-1 ) / t
akp1 = ap( kcnext+k ) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-cone )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_${ci}$copy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_${ci}$swap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = ap( kc+j-1 )
ap( kc+j-1 ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = cone / ap( kc )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ci}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$spmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
, 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = ap( kcnext+1 )
ak = ap( kcnext ) / t
akp1 = ap( kc ) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-cone )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ci}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$spmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
kc+1 ), 1_${ik}$ )
ap( kc ) = ap( kc ) - stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_${ci}$dotu( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
2_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_${ci}$copy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$spmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = ap( kc+j-k )
ap( kc+j-k ) = ap( kx )
ap( kx ) = temp
end do
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_${ci}$sptri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
!! SSPRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric indefinite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
iwork, info )
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: afp(*), ap(*), b(ldb,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
real(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_sspmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
ik = kk
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_ssptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n, info )
call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_slacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_ssptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n,info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_ssptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_ssprfs
pure module subroutine stdlib${ii}$_dsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
!! DSPRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric indefinite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
iwork, info )
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: afp(*), ap(*), b(ldb,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
real(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dspmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
ik = kk
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_dsptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n, info )
call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_dlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_dsptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n,info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_dsptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_dsprfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
!! DSPRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric indefinite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
iwork, info )
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: afp(*), ap(*), b(ldb,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
real(${rk}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$spmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
ik = kk
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ri}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n, info )
call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_${ri}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n,info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_${ri}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ri}$sprfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
!! CSPRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric indefinite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
rwork, info )
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: afp(*), ap(*), b(ldb,*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(sp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSPRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cspmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
ik = kk
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + cabs1( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_clacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_csprfs
pure module subroutine stdlib${ii}$_zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
!! ZSPRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric indefinite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
rwork, info )
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: afp(*), ap(*), b(ldb,*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(dp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zspmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
ik = kk
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + cabs1( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_zlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_zsprfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
!! ZSPRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric indefinite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
rwork, info )
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: afp(*), ap(*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(${ck}$) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$spmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
ik = kk
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + cabs1( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_${ci}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_${ci}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ci}$sprfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
!! SSYCON_ROOK estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by SSYTRF_ROOK.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(sp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYCON_ROOK', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_ssytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_ssycon_rook
pure module subroutine stdlib${ii}$_dsycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
!! DSYCON_ROOK estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(dp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYCON_ROOK', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_dsytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_dsycon_rook
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
!! DSYCON_ROOK: estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(in) :: anorm
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(${rk}$) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYCON_ROOK', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_${ri}$sytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ri}$sycon_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! CSYCON_ROOK estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by CSYTRF_ROOK.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(sp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYCON_ROOK', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==czero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_csytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_csycon_rook
pure module subroutine stdlib${ii}$_zsycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! ZSYCON_ROOK estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by ZSYTRF_ROOK.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(dp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYCON_ROOK', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==czero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_zsytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_zsycon_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! ZSYCON_ROOK: estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by ZSYTRF_ROOK.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(${ck}$) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYCON_ROOK', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==czero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_${ci}$sytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ci}$sycon_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
!! SSYTRF_ROOK computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
!! The form of the factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .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 = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, n*nb )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRF_ROOK', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rook;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_slasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_ssytf2_rook( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! no need to adjust ipiv
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rook;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_slasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
ldwork, iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_ssytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssytrf_rook
pure module subroutine stdlib${ii}$_dsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
!! DSYTRF_ROOK computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
!! The form of the factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .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 = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, n*nb )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRF_ROOK', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rook;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_dlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_dsytf2_rook( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! no need to adjust ipiv
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rook;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_dlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
ldwork, iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_dsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsytrf_rook
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
!! DSYTRF_ROOK: computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
!! The form of the factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .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 = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, n*nb )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRF_ROOK', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_${ri}$lasyf_rook;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_${ri}$lasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_${ri}$sytf2_rook( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! no need to adjust ipiv
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_${ri}$lasyf_rook;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_${ri}$lasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
ldwork, iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_${ri}$sytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sytrf_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
!! CSYTRF_ROOK computes the factorization of a complex symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
!! The form of the factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .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 = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, n*nb )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYTRF_ROOK', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_clasyf_rook;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_clasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_csytf2_rook( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! no need to adjust ipiv
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_clasyf_rook;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_clasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
ldwork, iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_csytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_csytrf_rook
pure module subroutine stdlib${ii}$_zsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
!! ZSYTRF_ROOK computes the factorization of a complex symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
!! The form of the factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .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 = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, n*nb )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRF_ROOK', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_zlasyf_rook;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_zlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_zsytf2_rook( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! no need to adjust ipiv
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_zlasyf_rook;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_zlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
ldwork, iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_zsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zsytrf_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
!! ZSYTRF_ROOK: computes the factorization of a complex symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
!! The form of the factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .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 = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, n*nb )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRF_ROOK', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf_rook;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_${ci}$lasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_${ci}$sytf2_rook( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! no need to adjust ipiv
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf_rook;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_${ci}$lasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
ldwork, iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_${ci}$sytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$sytrf_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
!! SLASYF_ROOK computes a partial factorization of a real symmetric
!! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method. The partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! SLASYF_ROOK is an auxiliary routine called by SSYTRF_ROOK. It uses
!! blocked code (calling Level 3 BLAS) to update the submatrix
!! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
ii
real(sp) :: absakk, alpha, colmax, d11, d12, d21, d22, stemp, r1, rowmax, t, &
sfmin
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_slamch( 'S' )
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
k = n
10 continue
! kw is the column of w which corresponds to column k of a
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
p = k
! copy column k of a to column kw of w and update it
call stdlib${ii}$_scopy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', k, n-k, -one, a( 1_${ik}$, k+1 ),lda, w( k, kw+&
1_${ik}$ ), ldw, one, w( 1_${ik}$, kw ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, kw ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_isamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = abs( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_scopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_scopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', k, n-k, -one,a( 1_${ik}$, k+1 ), lda, &
w( imax, kw+1 ), ldw,one, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_isamax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
rowmax = abs( w( jmax, kw-1 ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_isamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
stemp = abs( w( itemp, kw-1 ) )
if( stemp>rowmax ) then
rowmax = stemp
jmax = itemp
end if
end if
! equivalent to testing for
! abs( w( imax, kw-1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.(abs( w( imax, kw-1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k-1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! ============================================================
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_scopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
call stdlib${ii}$_scopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
! interchange rows k and p in last n-k+1 columns of a
! and last n-k+2 columns of w
call stdlib${ii}$_sswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
call stdlib${ii}$_sswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
end if
! updated column kp is already stored in column kkw of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_scopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_scopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last n-kk+1 columns
! of a and w
call stdlib${ii}$_sswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
call stdlib${ii}$_sswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! store u(k) in column k of a
call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
if( abs( a( k, k ) )>=sfmin ) then
r1 = one / a( k, k )
call stdlib${ii}$_sscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else if( a( k, k )/=zero ) then
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
! hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
if( k>2_${ik}$ ) then
! store u(k) and u(k-1) in columns k and k-1 of a
d12 = w( k-1, kw )
d11 = w( k, kw ) / d12
d22 = w( k-1, kw-1 ) / d12
t = one / ( d11*d22-one )
do j = 1, k - 2
a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
if( j>=2_${ik}$ )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( &
1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n
j = k + 1_${ik}$
60 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j + 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j + 1_${ik}$
if( jp2/=jj .and. j<=n )call stdlib${ii}$_sswap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
lda )
jj = j - 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_sswap( n-j+1, a( jp1, j ), lda, a( jj, j &
), lda )
if( j<=n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
p = k
! copy column k of a to column k of w and update it
call stdlib${ii}$_scopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, &
1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_isamax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = abs( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_scopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
72 continue
! begin pivot search loop body
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
call stdlib${ii}$_scopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), &
lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_isamax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = abs( w( jmax, k+1 ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_isamax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
stemp = abs( w( itemp, k+1 ) )
if( stemp>rowmax ) then
rowmax = stemp
jmax = itemp
end if
end if
! equivalent to testing for
! abs( w( imax, k+1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.( abs( w( imax, k+1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_scopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_scopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 72
end if
! ============================================================
kk = k + kstep - 1_${ik}$
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_scopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
call stdlib${ii}$_scopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
! interchange rows k and p in first k columns of a
! and first k+1 columns of w
call stdlib${ii}$_sswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
call stdlib${ii}$_sswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
end if
! updated column kp is already stored in column kk of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_scopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
call stdlib${ii}$_scopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
! interchange rows kk and kp in first kk columns of a and w
call stdlib${ii}$_sswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_sswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
! store l(k) in column k of a
call stdlib${ii}$_scopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
if( abs( a( k, k ) )>=sfmin ) then
r1 = one / a( k, k )
call stdlib${ii}$_sscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
else if( a( k, k )/=zero ) then
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! store l(k) and l(k+1) in columns k and k+1 of a
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / d21
t = one / ( d11*d22-one )
do j = k + 2, n
a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
! computing blocks of nb columns at a time
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, &
1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ )
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,one, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! in columns 1:k-1
j = k - 1_${ik}$
120 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j - 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j - 1_${ik}$
if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_sswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
jj = j + 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_sswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
lda )
if( j>=1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_slasyf_rook
pure module subroutine stdlib${ii}$_dlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
!! DLASYF_ROOK computes a partial factorization of a real symmetric
!! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method. The partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! DLASYF_ROOK is an auxiliary routine called by DSYTRF_ROOK. It uses
!! blocked code (calling Level 3 BLAS) to update the submatrix
!! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
ii
real(dp) :: absakk, alpha, colmax, d11, d12, d21, d22, dtemp, r1, rowmax, t, &
sfmin
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_dlamch( 'S' )
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
k = n
10 continue
! kw is the column of w which corresponds to column k of a
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
p = k
! copy column k of a to column kw of w and update it
call stdlib${ii}$_dcopy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', k, n-k, -one, a( 1_${ik}$, k+1 ),lda, w( k, kw+&
1_${ik}$ ), ldw, one, w( 1_${ik}$, kw ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, kw ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_idamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = abs( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_dcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', k, n-k, -one,a( 1_${ik}$, k+1 ), lda, &
w( imax, kw+1 ), ldw,one, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_idamax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
rowmax = abs( w( jmax, kw-1 ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_idamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
dtemp = abs( w( itemp, kw-1 ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for
! abs( w( imax, kw-1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.(abs( w( imax, kw-1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k-1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! ============================================================
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_dcopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
call stdlib${ii}$_dcopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
! interchange rows k and p in last n-k+1 columns of a
! and last n-k+2 columns of w
call stdlib${ii}$_dswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
call stdlib${ii}$_dswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
end if
! updated column kp is already stored in column kkw of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_dcopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_dcopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last n-kk+1 columns
! of a and w
call stdlib${ii}$_dswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
call stdlib${ii}$_dswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! store u(k) in column k of a
call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
if( abs( a( k, k ) )>=sfmin ) then
r1 = one / a( k, k )
call stdlib${ii}$_dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else if( a( k, k )/=zero ) then
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
! hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
if( k>2_${ik}$ ) then
! store u(k) and u(k-1) in columns k and k-1 of a
d12 = w( k-1, kw )
d11 = w( k, kw ) / d12
d22 = w( k-1, kw-1 ) / d12
t = one / ( d11*d22-one )
do j = 1, k - 2
a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
if( j>=2_${ik}$ )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( &
1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n
j = k + 1_${ik}$
60 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j + 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j + 1_${ik}$
if( jp2/=jj .and. j<=n )call stdlib${ii}$_dswap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
lda )
jj = j - 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_dswap( n-j+1, a( jp1, j ), lda, a( jj, j &
), lda )
if( j<=n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
p = k
! copy column k of a to column k of w and update it
call stdlib${ii}$_dcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, &
1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_idamax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = abs( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_dcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
72 continue
! begin pivot search loop body
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_dcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
call stdlib${ii}$_dcopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), &
lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_idamax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = abs( w( jmax, k+1 ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_idamax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
dtemp = abs( w( itemp, k+1 ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for
! abs( w( imax, k+1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.( abs( w( imax, k+1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 72
end if
! ============================================================
kk = k + kstep - 1_${ik}$
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_dcopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
call stdlib${ii}$_dcopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
! interchange rows k and p in first k columns of a
! and first k+1 columns of w
call stdlib${ii}$_dswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
call stdlib${ii}$_dswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
end if
! updated column kp is already stored in column kk of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_dcopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
call stdlib${ii}$_dcopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
! interchange rows kk and kp in first kk columns of a and w
call stdlib${ii}$_dswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_dswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
! store l(k) in column k of a
call stdlib${ii}$_dcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
if( abs( a( k, k ) )>=sfmin ) then
r1 = one / a( k, k )
call stdlib${ii}$_dscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
else if( a( k, k )/=zero ) then
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! store l(k) and l(k+1) in columns k and k+1 of a
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / d21
t = one / ( d11*d22-one )
do j = k + 2, n
a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
! computing blocks of nb columns at a time
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, &
1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ )
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,one, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! in columns 1:k-1
j = k - 1_${ik}$
120 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j - 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j - 1_${ik}$
if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_dswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
jj = j + 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_dswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
lda )
if( j>=1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_dlasyf_rook
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
!! DLASYF_ROOK: computes a partial factorization of a real symmetric
!! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method. The partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! DLASYF_ROOK is an auxiliary routine called by DSYTRF_ROOK. It uses
!! blocked code (calling Level 3 BLAS) to update the submatrix
!! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: sevten = 17.0e+0_${rk}$
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
ii
real(${rk}$) :: absakk, alpha, colmax, d11, d12, d21, d22, dtemp, r1, rowmax, t, &
sfmin
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_${ri}$lamch( 'S' )
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
k = n
10 continue
! kw is the column of w which corresponds to column k of a
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
p = k
! copy column k of a to column kw of w and update it
call stdlib${ii}$_${ri}$copy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', k, n-k, -one, a( 1_${ik}$, k+1 ),lda, w( k, kw+&
1_${ik}$ ), ldw, one, w( 1_${ik}$, kw ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, kw ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_i${ri}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = abs( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_${ri}$copy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', k, n-k, -one,a( 1_${ik}$, k+1 ), lda, &
w( imax, kw+1 ), ldw,one, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_i${ri}$amax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
rowmax = abs( w( jmax, kw-1 ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_i${ri}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
dtemp = abs( w( itemp, kw-1 ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for
! abs( w( imax, kw-1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.(abs( w( imax, kw-1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k-1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! ============================================================
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_${ri}$copy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
call stdlib${ii}$_${ri}$copy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
! interchange rows k and p in last n-k+1 columns of a
! and last n-k+2 columns of w
call stdlib${ii}$_${ri}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda )
call stdlib${ii}$_${ri}$swap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
end if
! updated column kp is already stored in column kkw of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_${ri}$copy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_${ri}$copy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last n-kk+1 columns
! of a and w
call stdlib${ii}$_${ri}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
call stdlib${ii}$_${ri}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! store u(k) in column k of a
call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
if( abs( a( k, k ) )>=sfmin ) then
r1 = one / a( k, k )
call stdlib${ii}$_${ri}$scal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else if( a( k, k )/=zero ) then
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
! hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
if( k>2_${ik}$ ) then
! store u(k) and u(k-1) in columns k and k-1 of a
d12 = w( k-1, kw )
d11 = w( k, kw ) / d12
d22 = w( k-1, kw-1 ) / d12
t = one / ( d11*d22-one )
do j = 1, k - 2
a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
if( j>=2_${ik}$ )call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( &
1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n
j = k + 1_${ik}$
60 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j + 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j + 1_${ik}$
if( jp2/=jj .and. j<=n )call stdlib${ii}$_${ri}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
lda )
jj = j - 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ri}$swap( n-j+1, a( jp1, j ), lda, a( jj, j &
), lda )
if( j<=n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
p = k
! copy column k of a to column k of w and update it
call stdlib${ii}$_${ri}$copy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, &
1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_i${ri}$amax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = abs( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
72 continue
! begin pivot search loop body
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_${ri}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
call stdlib${ii}$_${ri}$copy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), &
lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_i${ri}$amax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = abs( w( jmax, k+1 ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_i${ri}$amax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
dtemp = abs( w( itemp, k+1 ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for
! abs( w( imax, k+1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.( abs( w( imax, k+1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 72
end if
! ============================================================
kk = k + kstep - 1_${ik}$
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_${ri}$copy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
call stdlib${ii}$_${ri}$copy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
! interchange rows k and p in first k columns of a
! and first k+1 columns of w
call stdlib${ii}$_${ri}$swap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
call stdlib${ii}$_${ri}$swap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
end if
! updated column kp is already stored in column kk of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_${ri}$copy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
call stdlib${ii}$_${ri}$copy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
! interchange rows kk and kp in first kk columns of a and w
call stdlib${ii}$_${ri}$swap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_${ri}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
! store l(k) in column k of a
call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
if( abs( a( k, k ) )>=sfmin ) then
r1 = one / a( k, k )
call stdlib${ii}$_${ri}$scal( n-k, r1, a( k+1, k ), 1_${ik}$ )
else if( a( k, k )/=zero ) then
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! store l(k) and l(k+1) in columns k and k+1 of a
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / d21
t = one / ( d11*d22-one )
do j = k + 2, n
a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
! computing blocks of nb columns at a time
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, &
1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ )
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,one, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! in columns 1:k-1
j = k - 1_${ik}$
120 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j - 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j - 1_${ik}$
if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ri}$swap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
jj = j + 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ri}$swap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
lda )
if( j>=1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_${ri}$lasyf_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
!! CLASYF_ROOK computes a partial factorization of a complex symmetric
!! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method. The partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! CLASYF_ROOK is an auxiliary routine called by CSYTRF_ROOK. It uses
!! blocked code (calling Level 3 BLAS) to update the submatrix
!! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
ii
real(sp) :: absakk, alpha, colmax, rowmax, stemp, sfmin
complex(sp) :: d11, d12, d21, d22, r1, t, z
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) )
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_slamch( 'S' )
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
k = n
10 continue
! kw is the column of w which corresponds to column k of a
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
p = k
! copy column k of a to column kw of w and update it
call stdlib${ii}$_ccopy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ),lda, w( k, &
kw+1 ), ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( w( k, kw ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = cabs1( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_ccopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda,&
w( imax, kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_icamax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
rowmax = cabs1( w( jmax, kw-1 ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
stemp = cabs1( w( itemp, kw-1 ) )
if( stemp>rowmax ) then
rowmax = stemp
jmax = itemp
end if
end if
! equivalent to testing for
! cabs1( w( imax, kw-1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.(cabs1( w( imax, kw-1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k-1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! ============================================================
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_ccopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
call stdlib${ii}$_ccopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
! interchange rows k and p in last n-k+1 columns of a
! and last n-k+2 columns of w
call stdlib${ii}$_cswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
call stdlib${ii}$_cswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
end if
! updated column kp is already stored in column kkw of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_ccopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_ccopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last n-kk+1 columns
! of a and w
call stdlib${ii}$_cswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
call stdlib${ii}$_cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! store u(k) in column k of a
call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
if( cabs1( a( k, k ) )>=sfmin ) then
r1 = cone / a( k, k )
call stdlib${ii}$_cscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else if( a( k, k )/=czero ) then
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
! hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
if( k>2_${ik}$ ) then
! store u(k) and u(k-1) in columns k and k-1 of a
d12 = w( k-1, kw )
d11 = w( k, kw ) / d12
d22 = w( k-1, kw-1 ) / d12
t = cone / ( d11*d22-cone )
do j = 1, k - 2
a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
if( j>=2_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( &
1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n
j = k + 1_${ik}$
60 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j + 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j + 1_${ik}$
if( jp2/=jj .and. j<=n )call stdlib${ii}$_cswap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
lda )
jj = j - 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_cswap( n-j+1, a( jp1, j ), lda, a( jj, j &
), lda )
if( j<=n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
p = k
! copy column k of a to column k of w and update it
call stdlib${ii}$_ccopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, &
1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_icamax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = cabs1( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
72 continue
! begin pivot search loop body
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
call stdlib${ii}$_ccopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), &
lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, k+1 ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_icamax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
stemp = cabs1( w( itemp, k+1 ) )
if( stemp>rowmax ) then
rowmax = stemp
jmax = itemp
end if
end if
! equivalent to testing for
! cabs1( w( imax, k+1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.( cabs1( w( imax, k+1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 72
end if
! ============================================================
kk = k + kstep - 1_${ik}$
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_ccopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
call stdlib${ii}$_ccopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
! interchange rows k and p in first k columns of a
! and first k+1 columns of w
call stdlib${ii}$_cswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
call stdlib${ii}$_cswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
end if
! updated column kp is already stored in column kk of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_ccopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
call stdlib${ii}$_ccopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
! interchange rows kk and kp in first kk columns of a and w
call stdlib${ii}$_cswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
! store l(k) in column k of a
call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
if( cabs1( a( k, k ) )>=sfmin ) then
r1 = cone / a( k, k )
call stdlib${ii}$_cscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
else if( a( k, k )/=czero ) then
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! store l(k) and l(k+1) in columns k and k+1 of a
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / d21
t = cone / ( d11*d22-cone )
do j = k + 2, n
a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
! computing blocks of nb columns at a time
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! in columns 1:k-1
j = k - 1_${ik}$
120 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j - 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j - 1_${ik}$
if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_cswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
jj = j + 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_cswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
lda )
if( j>=1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_clasyf_rook
pure module subroutine stdlib${ii}$_zlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
!! ZLASYF_ROOK computes a partial factorization of a complex symmetric
!! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method. The partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! ZLASYF_ROOK is an auxiliary routine called by ZSYTRF_ROOK. It uses
!! blocked code (calling Level 3 BLAS) to update the submatrix
!! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
ii
real(dp) :: absakk, alpha, colmax, rowmax, dtemp, sfmin
complex(dp) :: d11, d12, d21, d22, r1, t, z
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) )
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_dlamch( 'S' )
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
k = n
10 continue
! kw is the column of w which corresponds to column k of a
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
p = k
! copy column k of a to column kw of w and update it
call stdlib${ii}$_zcopy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ),lda, w( k, &
kw+1 ), ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( w( k, kw ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = cabs1( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_zcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda,&
w( imax, kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_izamax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
rowmax = cabs1( w( jmax, kw-1 ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
dtemp = cabs1( w( itemp, kw-1 ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for
! cabs1( w( imax, kw-1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.(cabs1( w( imax, kw-1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k-1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! ============================================================
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_zcopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
call stdlib${ii}$_zcopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
! interchange rows k and p in last n-k+1 columns of a
! and last n-k+2 columns of w
call stdlib${ii}$_zswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
call stdlib${ii}$_zswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
end if
! updated column kp is already stored in column kkw of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_zcopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_zcopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last n-kk+1 columns
! of a and w
call stdlib${ii}$_zswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
call stdlib${ii}$_zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! store u(k) in column k of a
call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
if( cabs1( a( k, k ) )>=sfmin ) then
r1 = cone / a( k, k )
call stdlib${ii}$_zscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else if( a( k, k )/=czero ) then
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
! hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
if( k>2_${ik}$ ) then
! store u(k) and u(k-1) in columns k and k-1 of a
d12 = w( k-1, kw )
d11 = w( k, kw ) / d12
d22 = w( k-1, kw-1 ) / d12
t = cone / ( d11*d22-cone )
do j = 1, k - 2
a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
if( j>=2_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( &
1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n
j = k + 1_${ik}$
60 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j + 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j + 1_${ik}$
if( jp2/=jj .and. j<=n )call stdlib${ii}$_zswap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
lda )
jj = j - 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_zswap( n-j+1, a( jp1, j ), lda, a( jj, j &
), lda )
if( j<=n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
p = k
! copy column k of a to column k of w and update it
call stdlib${ii}$_zcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, &
1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_izamax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = cabs1( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
72 continue
! begin pivot search loop body
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
call stdlib${ii}$_zcopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), &
lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, k+1 ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_izamax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
dtemp = cabs1( w( itemp, k+1 ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for
! cabs1( w( imax, k+1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.( cabs1( w( imax, k+1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 72
end if
! ============================================================
kk = k + kstep - 1_${ik}$
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_zcopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
call stdlib${ii}$_zcopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
! interchange rows k and p in first k columns of a
! and first k+1 columns of w
call stdlib${ii}$_zswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
call stdlib${ii}$_zswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
end if
! updated column kp is already stored in column kk of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_zcopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
call stdlib${ii}$_zcopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
! interchange rows kk and kp in first kk columns of a and w
call stdlib${ii}$_zswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
! store l(k) in column k of a
call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
if( cabs1( a( k, k ) )>=sfmin ) then
r1 = cone / a( k, k )
call stdlib${ii}$_zscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
else if( a( k, k )/=czero ) then
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! store l(k) and l(k+1) in columns k and k+1 of a
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / d21
t = cone / ( d11*d22-cone )
do j = k + 2, n
a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
! computing blocks of nb columns at a time
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! in columns 1:k-1
j = k - 1_${ik}$
120 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j - 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j - 1_${ik}$
if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_zswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
jj = j + 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_zswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
lda )
if( j>=1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_zlasyf_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
!! ZLASYF_ROOK: computes a partial factorization of a complex symmetric
!! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method. The partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! ZLASYF_ROOK is an auxiliary routine called by ZSYTRF_ROOK. It uses
!! blocked code (calling Level 3 BLAS) to update the submatrix
!! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
ii
real(${ck}$) :: absakk, alpha, colmax, rowmax, dtemp, sfmin
complex(${ck}$) :: d11, d12, d21, d22, r1, t, z
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) )
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
k = n
10 continue
! kw is the column of w which corresponds to column k of a
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
p = k
! copy column k of a to column kw of w and update it
call stdlib${ii}$_${ci}$copy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ),lda, w( k, &
kw+1 ), ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( w( k, kw ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = cabs1( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_${ci}$copy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda,&
w( imax, kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
rowmax = cabs1( w( jmax, kw-1 ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
dtemp = cabs1( w( itemp, kw-1 ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for
! cabs1( w( imax, kw-1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.(cabs1( w( imax, kw-1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k-1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! ============================================================
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_${ci}$copy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
call stdlib${ii}$_${ci}$copy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
! interchange rows k and p in last n-k+1 columns of a
! and last n-k+2 columns of w
call stdlib${ii}$_${ci}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda )
call stdlib${ii}$_${ci}$swap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
end if
! updated column kp is already stored in column kkw of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_${ci}$copy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_${ci}$copy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last n-kk+1 columns
! of a and w
call stdlib${ii}$_${ci}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
call stdlib${ii}$_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! store u(k) in column k of a
call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
if( cabs1( a( k, k ) )>=sfmin ) then
r1 = cone / a( k, k )
call stdlib${ii}$_${ci}$scal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else if( a( k, k )/=czero ) then
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
! hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
if( k>2_${ik}$ ) then
! store u(k) and u(k-1) in columns k and k-1 of a
d12 = w( k-1, kw )
d11 = w( k, kw ) / d12
d22 = w( k-1, kw-1 ) / d12
t = cone / ( d11*d22-cone )
do j = 1, k - 2
a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
if( j>=2_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( &
1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n
j = k + 1_${ik}$
60 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j + 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j + 1_${ik}$
if( jp2/=jj .and. j<=n )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
lda )
jj = j - 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp1, j ), lda, a( jj, j &
), lda )
if( j<=n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
p = k
! copy column k of a to column k of w and update it
call stdlib${ii}$_${ci}$copy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, &
1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ )
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_i${ci}$amax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = cabs1( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
else
! ============================================================
! test for interchange
! equivalent to testing for absakk>=alpha*colmax
! (used to handle nan and inf)
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
72 continue
! begin pivot search loop body
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
call stdlib${ii}$_${ci}$copy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), &
lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, k+1 ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_i${ci}$amax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
dtemp = cabs1( w( itemp, k+1 ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for
! cabs1( w( imax, k+1 ) )>=alpha*rowmax
! (used to handle nan and inf)
if( .not.( cabs1( w( imax, k+1 ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
done = .true.
! equivalent to testing for rowmax==colmax,
! (used to handle nan and inf)
else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found: set params and repeat
p = imax
colmax = rowmax
imax = jmax
! copy updated jmaxth (next imaxth) column to kth of w
call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
end if
! end pivot search loop body
if( .not. done ) goto 72
end if
! ============================================================
kk = k + kstep - 1_${ik}$
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! copy non-updated column k to column p
call stdlib${ii}$_${ci}$copy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
call stdlib${ii}$_${ci}$copy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
! interchange rows k and p in first k columns of a
! and first k+1 columns of w
call stdlib${ii}$_${ci}$swap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$swap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
end if
! updated column kp is already stored in column kk of w
if( kp/=kk ) then
! copy non-updated column kk to column kp
a( kp, k ) = a( kk, k )
call stdlib${ii}$_${ci}$copy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
call stdlib${ii}$_${ci}$copy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
! interchange rows kk and kp in first kk columns of a and w
call stdlib${ii}$_${ci}$swap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
! store l(k) in column k of a
call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
if( cabs1( a( k, k ) )>=sfmin ) then
r1 = cone / a( k, k )
call stdlib${ii}$_${ci}$scal( n-k, r1, a( k+1, k ), 1_${ik}$ )
else if( a( k, k )/=czero ) then
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / a( k, k )
end do
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! store l(k) and l(k+1) in columns k and k+1 of a
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / d21
t = cone / ( d11*d22-cone )
do j = k + 2, n
a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
! computing blocks of nb columns at a time
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! in columns 1:k-1
j = k - 1_${ik}$
120 continue
kstep = 1_${ik}$
jp1 = 1_${ik}$
jj = j
jp2 = ipiv( j )
if( jp2<0_${ik}$ ) then
jp2 = -jp2
j = j - 1_${ik}$
jp1 = -ipiv( j )
kstep = 2_${ik}$
end if
j = j - 1_${ik}$
if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
jj = j + 1_${ik}$
if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
lda )
if( j>=1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_${ci}$lasyf_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytf2_rook( uplo, n, a, lda, ipiv, info )
!! SSYTF2_ROOK computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**T is the transpose of U, and D is symmetric and
!! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
logical(lk) :: upper, done
integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
real(sp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, stemp, t, wk, wkm1, &
wkp1, sfmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTF2_ROOK', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_slamch( 'S' )
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_isamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = abs( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange,
! use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_isamax( k-imax, a( imax, imax+1 ),lda )
rowmax = abs( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_isamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
stemp = abs( a( itemp, imax ) )
if( stemp>rowmax ) then
rowmax = stemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! abs( a( imax, imax ) )>=alpha*rowmax
if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the leading
! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
if( p>1_${ik}$ )call stdlib${ii}$_sswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
if( p<(k-1) )call stdlib${ii}$_sswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_sswap( kk-kp-1, a( kp+1, kk ), &
1_${ik}$, a( kp, kp+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
if( k>1_${ik}$ ) then
! perform a rank-1 update of a(1:k-1,1:k-1) and
! store u(k) in column k
if( abs( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*1/d(k)*w(k)**t
d11 = one / a( k, k )
call stdlib${ii}$_ssyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_sscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_ssyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k>2_${ik}$ ) then
d12 = a( k-1, k )
d22 = a( k-1, k-1 ) / d12
d11 = a( k, k ) / d12
t = one / ( d11*d22-one )
do j = k - 2, 1, -1
wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
wk = t*( d22*a( j, k )-a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
*wkm1
end do
! store u(k) and u(k-1) in cols k and k-1 for row j
a( j, k ) = wk / d12
a( j, k-1 ) = wkm1 / d12
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
40 continue
! if k > n, exit from loop
if( k>n )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_isamax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = abs( a( imax, k ) )
else
colmax = zero
end if
if( ( max( absakk, colmax )==zero ) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
42 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_isamax( imax-k, a( imax, k ), lda )
rowmax = abs( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_isamax( n-imax, a( imax+1, imax ),1_${ik}$ )
stemp = abs( a( itemp, imax ) )
if( stemp>rowmax ) then
rowmax = stemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! abs( a( imax, imax ) )>=alpha*rowmax
if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 42
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the trailing
! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
if( p<n )call stdlib${ii}$_sswap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
if( p>(k+1) )call stdlib${ii}$_sswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_sswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_sswap( kp-kk-1, a( kk+1, kk ), &
1_${ik}$, a( kp, kk+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) and
! store l(k) in column k
if( abs( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
d11 = one / a( k, k )
call stdlib${ii}$_ssyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_sscal( n-k, d11, a( k+1, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_ssyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k<n-1 ) then
d21 = a( k+1, k )
d11 = a( k+1, k+1 ) / d21
d22 = a( k, k ) / d21
t = one / ( d11*d22-one )
do j = k + 2, n
! compute d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
wk = t*( d11*a( j, k )-a( j, k+1 ) )
wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
! perform a rank-2 update of a(k+2:n,k+2:n)
do i = j, n
a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
*wkp1
end do
! store l(k) and l(k+1) in cols k and k+1 for row j
a( j, k ) = wk / d21
a( j, k+1 ) = wkp1 / d21
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 40
end if
70 continue
return
end subroutine stdlib${ii}$_ssytf2_rook
pure module subroutine stdlib${ii}$_dsytf2_rook( uplo, n, a, lda, ipiv, info )
!! DSYTF2_ROOK computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**T is the transpose of U, and D is symmetric and
!! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
logical(lk) :: upper, done
integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
real(dp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, dtemp, t, wk, wkm1, &
wkp1, sfmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTF2_ROOK', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_dlamch( 'S' )
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_idamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = abs( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange,
! use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_idamax( k-imax, a( imax, imax+1 ),lda )
rowmax = abs( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_idamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
dtemp = abs( a( itemp, imax ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! abs( a( imax, imax ) )>=alpha*rowmax
if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the leading
! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
if( p>1_${ik}$ )call stdlib${ii}$_dswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
if( p<(k-1) )call stdlib${ii}$_dswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_dswap( kk-kp-1, a( kp+1, kk ), &
1_${ik}$, a( kp, kp+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
if( k>1_${ik}$ ) then
! perform a rank-1 update of a(1:k-1,1:k-1) and
! store u(k) in column k
if( abs( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*1/d(k)*w(k)**t
d11 = one / a( k, k )
call stdlib${ii}$_dsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_dscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_dsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k>2_${ik}$ ) then
d12 = a( k-1, k )
d22 = a( k-1, k-1 ) / d12
d11 = a( k, k ) / d12
t = one / ( d11*d22-one )
do j = k - 2, 1, -1
wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
wk = t*( d22*a( j, k )-a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
*wkm1
end do
! store u(k) and u(k-1) in cols k and k-1 for row j
a( j, k ) = wk / d12
a( j, k-1 ) = wkm1 / d12
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
40 continue
! if k > n, exit from loop
if( k>n )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_idamax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = abs( a( imax, k ) )
else
colmax = zero
end if
if( ( max( absakk, colmax )==zero ) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
42 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_idamax( imax-k, a( imax, k ), lda )
rowmax = abs( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_idamax( n-imax, a( imax+1, imax ),1_${ik}$ )
dtemp = abs( a( itemp, imax ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! abs( a( imax, imax ) )>=alpha*rowmax
if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 42
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the trailing
! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
if( p<n )call stdlib${ii}$_dswap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
if( p>(k+1) )call stdlib${ii}$_dswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_dswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_dswap( kp-kk-1, a( kk+1, kk ), &
1_${ik}$, a( kp, kk+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) and
! store l(k) in column k
if( abs( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
d11 = one / a( k, k )
call stdlib${ii}$_dsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_dscal( n-k, d11, a( k+1, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_dsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k<n-1 ) then
d21 = a( k+1, k )
d11 = a( k+1, k+1 ) / d21
d22 = a( k, k ) / d21
t = one / ( d11*d22-one )
do j = k + 2, n
! compute d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
wk = t*( d11*a( j, k )-a( j, k+1 ) )
wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
! perform a rank-2 update of a(k+2:n,k+2:n)
do i = j, n
a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
*wkp1
end do
! store l(k) and l(k+1) in cols k and k+1 for row j
a( j, k ) = wk / d21
a( j, k+1 ) = wkp1 / d21
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 40
end if
70 continue
return
end subroutine stdlib${ii}$_dsytf2_rook
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytf2_rook( uplo, n, a, lda, ipiv, info )
!! DSYTF2_ROOK: computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**T is the transpose of U, and D is symmetric and
!! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: sevten = 17.0e+0_${rk}$
! Local Scalars
logical(lk) :: upper, done
integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
real(${rk}$) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, dtemp, t, wk, wkm1, &
wkp1, sfmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTF2_ROOK', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_${ri}$lamch( 'S' )
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_i${ri}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = abs( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange,
! use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_i${ri}$amax( k-imax, a( imax, imax+1 ),lda )
rowmax = abs( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_i${ri}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
dtemp = abs( a( itemp, imax ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! abs( a( imax, imax ) )>=alpha*rowmax
if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the leading
! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
if( p>1_${ik}$ )call stdlib${ii}$_${ri}$swap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
if( p<(k-1) )call stdlib${ii}$_${ri}$swap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_${ri}$swap( kk-kp-1, a( kp+1, kk ), &
1_${ik}$, a( kp, kp+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
if( k>1_${ik}$ ) then
! perform a rank-1 update of a(1:k-1,1:k-1) and
! store u(k) in column k
if( abs( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*1/d(k)*w(k)**t
d11 = one / a( k, k )
call stdlib${ii}$_${ri}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_${ri}$scal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_${ri}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k>2_${ik}$ ) then
d12 = a( k-1, k )
d22 = a( k-1, k-1 ) / d12
d11 = a( k, k ) / d12
t = one / ( d11*d22-one )
do j = k - 2, 1, -1
wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
wk = t*( d22*a( j, k )-a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
*wkm1
end do
! store u(k) and u(k-1) in cols k and k-1 for row j
a( j, k ) = wk / d12
a( j, k-1 ) = wkm1 / d12
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
40 continue
! if k > n, exit from loop
if( k>n )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_i${ri}$amax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = abs( a( imax, k ) )
else
colmax = zero
end if
if( ( max( absakk, colmax )==zero ) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
42 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_i${ri}$amax( imax-k, a( imax, k ), lda )
rowmax = abs( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_i${ri}$amax( n-imax, a( imax+1, imax ),1_${ik}$ )
dtemp = abs( a( itemp, imax ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! abs( a( imax, imax ) )>=alpha*rowmax
if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 42
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the trailing
! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
if( p<n )call stdlib${ii}$_${ri}$swap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
if( p>(k+1) )call stdlib${ii}$_${ri}$swap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_${ri}$swap( kp-kk-1, a( kk+1, kk ), &
1_${ik}$, a( kp, kk+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) and
! store l(k) in column k
if( abs( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
d11 = one / a( k, k )
call stdlib${ii}$_${ri}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_${ri}$scal( n-k, d11, a( k+1, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_${ri}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k<n-1 ) then
d21 = a( k+1, k )
d11 = a( k+1, k+1 ) / d21
d22 = a( k, k ) / d21
t = one / ( d11*d22-one )
do j = k + 2, n
! compute d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
wk = t*( d11*a( j, k )-a( j, k+1 ) )
wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
! perform a rank-2 update of a(k+2:n,k+2:n)
do i = j, n
a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
*wkp1
end do
! store l(k) and l(k+1) in cols k and k+1 for row j
a( j, k ) = wk / d21
a( j, k+1 ) = wkp1 / d21
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 40
end if
70 continue
return
end subroutine stdlib${ii}$_${ri}$sytf2_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytf2_rook( uplo, n, a, lda, ipiv, info )
!! CSYTF2_ROOK computes the factorization of a complex symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**T is the transpose of U, and D is symmetric and
!! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
logical(lk) :: upper, done
integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
real(sp) :: absakk, alpha, colmax, rowmax, stemp, sfmin
complex(sp) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYTF2_ROOK', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_slamch( 'S' )
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange,
! use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ),lda )
rowmax = cabs1( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
stemp = cabs1( a( itemp, imax ) )
if( stemp>rowmax ) then
rowmax = stemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! cabs1( a( imax, imax ) )>=alpha*rowmax
if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the leading
! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
if( p>1_${ik}$ )call stdlib${ii}$_cswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
if( p<(k-1) )call stdlib${ii}$_cswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_cswap( kk-kp-1, a( kp+1, kk ), &
1_${ik}$, a( kp, kp+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
if( k>1_${ik}$ ) then
! perform a rank-1 update of a(1:k-1,1:k-1) and
! store u(k) in column k
if( cabs1( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*1/d(k)*w(k)**t
d11 = cone / a( k, k )
call stdlib${ii}$_csyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_cscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_csyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k>2_${ik}$ ) then
d12 = a( k-1, k )
d22 = a( k-1, k-1 ) / d12
d11 = a( k, k ) / d12
t = cone / ( d11*d22-cone )
do j = k - 2, 1, -1
wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
wk = t*( d22*a( j, k )-a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
*wkm1
end do
! store u(k) and u(k-1) in cols k and k-1 for row j
a( j, k ) = wk / d12
a( j, k-1 ) = wkm1 / d12
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
40 continue
! if k > n, exit from loop
if( k>n )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_icamax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( ( max( absakk, colmax )==zero ) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
42 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, a( imax, k ), lda )
rowmax = cabs1( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_icamax( n-imax, a( imax+1, imax ),1_${ik}$ )
stemp = cabs1( a( itemp, imax ) )
if( stemp>rowmax ) then
rowmax = stemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! cabs1( a( imax, imax ) )>=alpha*rowmax
if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 42
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the trailing
! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
if( p<n )call stdlib${ii}$_cswap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
if( p>(k+1) )call stdlib${ii}$_cswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_cswap( kp-kk-1, a( kk+1, kk ), &
1_${ik}$, a( kp, kk+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) and
! store l(k) in column k
if( cabs1( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
d11 = cone / a( k, k )
call stdlib${ii}$_csyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_cscal( n-k, d11, a( k+1, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_csyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k<n-1 ) then
d21 = a( k+1, k )
d11 = a( k+1, k+1 ) / d21
d22 = a( k, k ) / d21
t = cone / ( d11*d22-cone )
do j = k + 2, n
! compute d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
wk = t*( d11*a( j, k )-a( j, k+1 ) )
wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
! perform a rank-2 update of a(k+2:n,k+2:n)
do i = j, n
a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
*wkp1
end do
! store l(k) and l(k+1) in cols k and k+1 for row j
a( j, k ) = wk / d21
a( j, k+1 ) = wkp1 / d21
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 40
end if
70 continue
return
end subroutine stdlib${ii}$_csytf2_rook
pure module subroutine stdlib${ii}$_zsytf2_rook( uplo, n, a, lda, ipiv, info )
!! ZSYTF2_ROOK computes the factorization of a complex symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**T is the transpose of U, and D is symmetric and
!! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
logical(lk) :: upper, done
integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
real(dp) :: absakk, alpha, colmax, rowmax, dtemp, sfmin
complex(dp) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTF2_ROOK', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_dlamch( 'S' )
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange,
! use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ),lda )
rowmax = cabs1( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
dtemp = cabs1( a( itemp, imax ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! cabs1( a( imax, imax ) )>=alpha*rowmax
if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the leading
! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
if( p>1_${ik}$ )call stdlib${ii}$_zswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
if( p<(k-1) )call stdlib${ii}$_zswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_zswap( kk-kp-1, a( kp+1, kk ), &
1_${ik}$, a( kp, kp+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
if( k>1_${ik}$ ) then
! perform a rank-1 update of a(1:k-1,1:k-1) and
! store u(k) in column k
if( cabs1( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*1/d(k)*w(k)**t
d11 = cone / a( k, k )
call stdlib${ii}$_zsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_zscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_zsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k>2_${ik}$ ) then
d12 = a( k-1, k )
d22 = a( k-1, k-1 ) / d12
d11 = a( k, k ) / d12
t = cone / ( d11*d22-cone )
do j = k - 2, 1, -1
wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
wk = t*( d22*a( j, k )-a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
*wkm1
end do
! store u(k) and u(k-1) in cols k and k-1 for row j
a( j, k ) = wk / d12
a( j, k-1 ) = wkm1 / d12
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
40 continue
! if k > n, exit from loop
if( k>n )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_izamax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( ( max( absakk, colmax )==zero ) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
42 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, a( imax, k ), lda )
rowmax = cabs1( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_izamax( n-imax, a( imax+1, imax ),1_${ik}$ )
dtemp = cabs1( a( itemp, imax ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! cabs1( a( imax, imax ) )>=alpha*rowmax
if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 42
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the trailing
! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
if( p<n )call stdlib${ii}$_zswap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
if( p>(k+1) )call stdlib${ii}$_zswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_zswap( kp-kk-1, a( kk+1, kk ), &
1_${ik}$, a( kp, kk+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) and
! store l(k) in column k
if( cabs1( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
d11 = cone / a( k, k )
call stdlib${ii}$_zsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_zscal( n-k, d11, a( k+1, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_zsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k<n-1 ) then
d21 = a( k+1, k )
d11 = a( k+1, k+1 ) / d21
d22 = a( k, k ) / d21
t = cone / ( d11*d22-cone )
do j = k + 2, n
! compute d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
wk = t*( d11*a( j, k )-a( j, k+1 ) )
wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
! perform a rank-2 update of a(k+2:n,k+2:n)
do i = j, n
a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
*wkp1
end do
! store l(k) and l(k+1) in cols k and k+1 for row j
a( j, k ) = wk / d21
a( j, k+1 ) = wkp1 / d21
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 40
end if
70 continue
return
end subroutine stdlib${ii}$_zsytf2_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytf2_rook( uplo, n, a, lda, ipiv, info )
!! ZSYTF2_ROOK: computes the factorization of a complex symmetric matrix A
!! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**T is the transpose of U, and D is symmetric and
!! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$
! Local Scalars
logical(lk) :: upper, done
integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
real(${ck}$) :: absakk, alpha, colmax, rowmax, dtemp, sfmin
complex(${ck}$) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTF2_ROOK', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
! compute machine safe minimum
sfmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange,
! use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
12 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ),lda )
rowmax = cabs1( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax>1_${ik}$ ) then
itemp = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
dtemp = cabs1( a( itemp, imax ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! cabs1( a( imax, imax ) )>=alpha*rowmax
if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 12
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the leading
! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
if( p>1_${ik}$ )call stdlib${ii}$_${ci}$swap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
if( p<(k-1) )call stdlib${ii}$_${ci}$swap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_${ci}$swap( kk-kp-1, a( kp+1, kk ), &
1_${ik}$, a( kp, kp+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
if( k>1_${ik}$ ) then
! perform a rank-1 update of a(1:k-1,1:k-1) and
! store u(k) in column k
if( cabs1( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*1/d(k)*w(k)**t
d11 = cone / a( k, k )
call stdlib${ii}$_${ci}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_${ci}$scal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = 1, k - 1
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - u(k)*d(k)*u(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_${ci}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k>2_${ik}$ ) then
d12 = a( k-1, k )
d22 = a( k-1, k-1 ) / d12
d11 = a( k, k ) / d12
t = cone / ( d11*d22-cone )
do j = k - 2, 1, -1
wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
wk = t*( d22*a( j, k )-a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
*wkm1
end do
! store u(k) and u(k-1) in cols k and k-1 for row j
a( j, k ) = wk / d12
a( j, k-1 ) = wkm1 / d12
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
40 continue
! if k > n, exit from loop
if( k>n )go to 70
kstep = 1_${ik}$
p = k
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = cabs1( a( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_i${ci}$amax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( ( max( absakk, colmax )==zero ) ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
! test for interchange
! equivalent to testing for (used to handle nan and inf)
! absakk>=alpha*colmax
if( .not.( absakk<alpha*colmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
done = .false.
! loop until pivot found
42 continue
! begin pivot search loop body
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine both rowmax and jmax.
if( imax/=k ) then
jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, a( imax, k ), lda )
rowmax = cabs1( a( imax, jmax ) )
else
rowmax = zero
end if
if( imax<n ) then
itemp = imax + stdlib${ii}$_i${ci}$amax( n-imax, a( imax+1, imax ),1_${ik}$ )
dtemp = cabs1( a( itemp, imax ) )
if( dtemp>rowmax ) then
rowmax = dtemp
jmax = itemp
end if
end if
! equivalent to testing for (used to handle nan and inf)
! cabs1( a( imax, imax ) )>=alpha*rowmax
if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
! interchange rows and columns k and imax,
! use 1-by-1 pivot block
kp = imax
done = .true.
! equivalent to testing for rowmax == colmax,
! used to handle nan and inf
else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
! interchange rows and columns k+1 and imax,
! use 2-by-2 pivot block
kp = imax
kstep = 2_${ik}$
done = .true.
else
! pivot not found, set variables and repeat
p = imax
colmax = rowmax
imax = jmax
end if
! end pivot search loop body
if( .not. done ) goto 42
end if
! swap two rows and two columns
! first swap
if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
! interchange rows and column k and p in the trailing
! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
if( p<n )call stdlib${ii}$_${ci}$swap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
if( p>(k+1) )call stdlib${ii}$_${ci}$swap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
t = a( k, k )
a( k, k ) = a( p, p )
a( p, p ) = t
end if
! second swap
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_${ci}$swap( kp-kk-1, a( kk+1, kk ), &
1_${ik}$, a( kp, kk+1 ),lda )
t = a( kk, kk )
a( kk, kk ) = a( kp, kp )
a( kp, kp ) = t
if( kstep==2_${ik}$ ) then
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) and
! store l(k) in column k
if( cabs1( a( k, k ) )>=sfmin ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
d11 = cone / a( k, k )
call stdlib${ii}$_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_${ci}$scal( n-k, d11, a( k+1, k ), 1_${ik}$ )
else
! store l(k) in column k
d11 = a( k, k )
do ii = k + 1, n
a( ii, k ) = a( ii, k ) / d11
end do
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**t
! = a - w(k)*(1/d(k))*w(k)**t
! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
call stdlib${ii}$_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
end if
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
! and store l(k) and l(k+1) in columns k and k+1
if( k<n-1 ) then
d21 = a( k+1, k )
d11 = a( k+1, k+1 ) / d21
d22 = a( k, k ) / d21
t = cone / ( d11*d22-cone )
do j = k + 2, n
! compute d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
wk = t*( d11*a( j, k )-a( j, k+1 ) )
wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
! perform a rank-2 update of a(k+2:n,k+2:n)
do i = j, n
a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
*wkp1
end do
! store l(k) and l(k+1) in cols k and k+1 for row j
a( j, k ) = wk / d21
a( j, k+1 ) = wkp1 / d21
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -p
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 40
end if
70 continue
return
end subroutine stdlib${ii}$_${ci}$sytf2_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
!! SSYTRS_ROOK solves a system of linear equations A*X = B with
!! a real symmetric matrix A using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by SSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
real(sp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRS_ROOK', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_sger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_sscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
if( k>2_${ik}$ ) then
call stdlib${ii}$_sger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
call stdlib${ii}$_sger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ),&
ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, one, b( &
k, 1_${ik}$ ), ldb )
call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, one, &
b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_sswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_sger( n-k, nrhs, -one, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_sscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_sswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_sger( n-k-1, nrhs, -one, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ &
), ldb )
call stdlib${ii}$_sger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / akm1k
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+&
1_${ik}$, k ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k ),&
1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-1 &
), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_ssytrs_rook
pure module subroutine stdlib${ii}$_dsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
!! DSYTRS_ROOK solves a system of linear equations A*X = B with
!! a real symmetric matrix A using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by DSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
real(dp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRS_ROOK', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_dger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_dscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
if( k>2_${ik}$ ) then
call stdlib${ii}$_dger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
call stdlib${ii}$_dger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ),&
ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, one, b( &
k, 1_${ik}$ ), ldb )
call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, one, &
b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_dswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_dger( n-k, nrhs, -one, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_dscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_dswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_dger( n-k-1, nrhs, -one, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ &
), ldb )
call stdlib${ii}$_dger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / akm1k
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+&
1_${ik}$, k ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k ),&
1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-1 &
), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_dsytrs_rook
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
!! DSYTRS_ROOK: solves a system of linear equations A*X = B with
!! a real symmetric matrix A using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by DSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
real(${rk}$) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRS_ROOK', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_${ri}$ger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_${ri}$scal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
if( k>2_${ik}$ ) then
call stdlib${ii}$_${ri}$ger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
call stdlib${ii}$_${ri}$ger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ),&
ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, one, b( &
k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, one, &
b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ri}$ger( n-k, nrhs, -one, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_${ri}$scal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_${ri}$ger( n-k-1, nrhs, -one, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ &
), ldb )
call stdlib${ii}$_${ri}$ger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / akm1k
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - one
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+&
1_${ik}$, k ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k ),&
1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-1 &
), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_${ri}$sytrs_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
!! CSYTRS_ROOK solves a system of linear equations A*X = B with
!! a complex symmetric matrix A using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by CSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYTRS_ROOK', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_cgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_cscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
if( k>2_${ik}$ ) then
call stdlib${ii}$_cgeru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
call stdlib${ii}$_cgeru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )&
, ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, &
b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,&
b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_cgeru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
k+1, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_cscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_cgeru( n-k-1, nrhs,-cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_cgeru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / akm1k
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+&
1_${ik}$, k ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k )&
, 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-&
1_${ik}$ ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_csytrs_rook
pure module subroutine stdlib${ii}$_zsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
!! ZSYTRS_ROOK solves a system of linear equations A*X = B with
!! a complex symmetric matrix A using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by ZSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRS_ROOK', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_zgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_zscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
if( k>2_${ik}$ ) then
call stdlib${ii}$_zgeru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
call stdlib${ii}$_zgeru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )&
, ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, &
b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,&
b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_zgeru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
k+1, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_zscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_zgeru( n-k-1, nrhs,-cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_zgeru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / akm1k
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+&
1_${ik}$, k ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k )&
, 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-&
1_${ik}$ ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_zsytrs_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
!! ZSYTRS_ROOK: solves a system of linear equations A*X = B with
!! a complex symmetric matrix A using the factorization A = U*D*U**T or
!! A = L*D*L**T computed by ZSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRS_ROOK', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**t.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
if( k>2_${ik}$ ) then
call stdlib${ii}$_${ci}$geru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
call stdlib${ii}$_${ci}$geru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )&
, ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / akm1k
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**t *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**t(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, &
b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,&
b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**t.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ci}$geru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
k+1, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
call stdlib${ii}$_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k+1 )
if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_${ci}$geru( n-k-1, nrhs,-cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$geru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
2_${ik}$, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / akm1k
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / akm1k
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**t *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**t(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+&
1_${ik}$, k ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k )&
, 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-&
1_${ik}$ ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
end if
! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kp = -ipiv( k-1 )
if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_${ci}$sytrs_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytri_rook( uplo, n, a, lda, ipiv, work, info )
!! SSYTRI_ROOK computes the inverse of a real symmetric
!! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
!! computed by SSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: k, kp, kstep
real(sp) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRI_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==zero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 40
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / a( k, k )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k+1 ) )
ak = a( k, k ) / t
akp1 = a( k+1, k+1 ) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-one )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_sdot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the leading
! submatrix a(1:k+1,1:k+1)
kp = ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k+1 with -ipiv(k) and
! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
k = k + 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k + 1_${ik}$
go to 30
40 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
50 continue
! if k < 1, exit from loop.
if( k<1 )go to 60
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / a( k, k )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_scopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ssymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k-1 ) )
ak = a( k-1, k-1 ) / t
akp1 = a( k, k ) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-one )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_scopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ssymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_sdot( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ )
call stdlib${ii}$_scopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ssymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_sdot( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the trailing
! submatrix a(k-1:n,k-1:n)
kp = ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_sswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_sswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k-1 with -ipiv(k) and
! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_sswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_sswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
k = k - 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_sswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_sswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k - 1_${ik}$
go to 50
60 continue
end if
return
end subroutine stdlib${ii}$_ssytri_rook
pure module subroutine stdlib${ii}$_dsytri_rook( uplo, n, a, lda, ipiv, work, info )
!! DSYTRI_ROOK computes the inverse of a real symmetric
!! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
!! computed by DSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: k, kp, kstep
real(dp) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRI_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==zero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 40
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / a( k, k )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k+1 ) )
ak = a( k, k ) / t
akp1 = a( k+1, k+1 ) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-one )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_ddot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the leading
! submatrix a(1:k+1,1:k+1)
kp = ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k+1 with -ipiv(k) and
! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
k = k + 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k + 1_${ik}$
go to 30
40 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
50 continue
! if k < 1, exit from loop.
if( k<1 )go to 60
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / a( k, k )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_dcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dsymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k-1 ) )
ak = a( k-1, k-1 ) / t
akp1 = a( k, k ) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-one )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_dcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dsymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_ddot( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ )
call stdlib${ii}$_dcopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_dsymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_ddot( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the trailing
! submatrix a(k-1:n,k-1:n)
kp = ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_dswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_dswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k-1 with -ipiv(k) and
! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_dswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_dswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
k = k - 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_dswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_dswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k - 1_${ik}$
go to 50
60 continue
end if
return
end subroutine stdlib${ii}$_dsytri_rook
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytri_rook( uplo, n, a, lda, ipiv, work, info )
!! DSYTRI_ROOK: computes the inverse of a real symmetric
!! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
!! computed by DSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: k, kp, kstep
real(${rk}$) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRI_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==zero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 40
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / a( k, k )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ri}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$symv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k+1 ) )
ak = a( k, k ) / t
akp1 = a( k+1, k+1 ) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-one )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ri}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$symv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ri}$dot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$symv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the leading
! submatrix a(1:k+1,1:k+1)
kp = ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_${ri}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k+1 with -ipiv(k) and
! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_${ri}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
k = k + 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_${ri}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k + 1_${ik}$
go to 30
40 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
50 continue
! if k < 1, exit from loop.
if( k<1 )go to 60
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / a( k, k )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ri}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$symv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k-1 ) )
ak = a( k-1, k-1 ) / t
akp1 = a( k, k ) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-one )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ri}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$symv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_${ri}$dot( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$symv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the trailing
! submatrix a(k-1:n,k-1:n)
kp = ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_${ri}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k-1 with -ipiv(k) and
! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_${ri}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
k = k - 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_${ri}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k - 1_${ik}$
go to 50
60 continue
end if
return
end subroutine stdlib${ii}$_${ri}$sytri_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytri_rook( uplo, n, a, lda, ipiv, work, info )
!! CSYTRI_ROOK computes the inverse of a complex symmetric
!! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
!! computed by CSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: k, kp, kstep
complex(sp) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYTRI_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 40
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = cone / a( k, k )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = a( k, k+1 )
ak = a( k, k ) / t
akp1 = a( k+1, k+1 ) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-cone )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_cdotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the leading
! submatrix a(1:k+1,1:k+1)
kp = ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k+1 with -ipiv(k) and
! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
k = k + 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k + 1_${ik}$
go to 30
40 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
50 continue
! if k < 1, exit from loop.
if( k<1 )go to 60
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = cone / a( k, k )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_ccopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = a( k, k-1 )
ak = a( k-1, k-1 ) / t
akp1 = a( k, k ) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-cone )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_ccopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_cdotu( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
)
call stdlib${ii}$_ccopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the trailing
! submatrix a(k-1:n,k-1:n)
kp = ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_cswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k-1 with -ipiv(k) and
! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_cswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
k = k - 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_cswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k - 1_${ik}$
go to 50
60 continue
end if
return
end subroutine stdlib${ii}$_csytri_rook
pure module subroutine stdlib${ii}$_zsytri_rook( uplo, n, a, lda, ipiv, work, info )
!! ZSYTRI_ROOK computes the inverse of a complex symmetric
!! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
!! computed by ZSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: k, kp, kstep
complex(dp) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRI_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 40
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = cone / a( k, k )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = a( k, k+1 )
ak = a( k, k ) / t
akp1 = a( k+1, k+1 ) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-cone )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_zdotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the leading
! submatrix a(1:k+1,1:k+1)
kp = ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k+1 with -ipiv(k) and
! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
k = k + 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k + 1_${ik}$
go to 30
40 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
50 continue
! if k < 1, exit from loop.
if( k<1 )go to 60
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = cone / a( k, k )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_zcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zsymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = a( k, k-1 )
ak = a( k-1, k-1 ) / t
akp1 = a( k, k ) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-cone )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_zcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zsymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_zdotu( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
)
call stdlib${ii}$_zcopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zsymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the trailing
! submatrix a(k-1:n,k-1:n)
kp = ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_zswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k-1 with -ipiv(k) and
! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_zswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
k = k - 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_zswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k - 1_${ik}$
go to 50
60 continue
end if
return
end subroutine stdlib${ii}$_zsytri_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytri_rook( uplo, n, a, lda, ipiv, work, info )
!! ZSYTRI_ROOK: computes the inverse of a complex symmetric
!! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
!! computed by ZSYTRF_ROOK.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: k, kp, kstep
complex(${ck}$) :: ak, akkp1, akp1, d, t, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .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 = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRI_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 40
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = cone / a( k, k )
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = a( k, k+1 )
ak = a( k, k ) / t
akp1 = a( k+1, k+1 ) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-cone )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ci}$dotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the leading
! submatrix a(1:k+1,1:k+1)
kp = ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k+1 with -ipiv(k) and
! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
k = k + 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k + 1_${ik}$
go to 30
40 continue
else
! compute inv(a) from the factorization a = l*d*l**t.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
50 continue
! if k < 1, exit from loop.
if( k<1 )go to 60
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = cone / a( k, k )
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$symv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = a( k, k-1 )
ak = a( k-1, k-1 ) / t
akp1 = a( k, k ) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-cone )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$symv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_${ci}$dotu( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
)
call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$symv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
end if
kstep = 2_${ik}$
end if
if( kstep==1_${ik}$ ) then
! interchange rows and columns k and ipiv(k) in the trailing
! submatrix a(k-1:n,k-1:n)
kp = ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_${ci}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
else
! interchange rows and columns k and k-1 with -ipiv(k) and
! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_${ci}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
k = k - 1_${ik}$
kp = -ipiv( k )
if( kp/=k ) then
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
call stdlib${ii}$_${ci}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
end if
end if
k = k - 1_${ik}$
go to 50
60 continue
end if
return
end subroutine stdlib${ii}$_${ci}$sytri_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
!! SSYTRF_RK computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
!! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
!! For more information see Further Details section.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, ip, iws, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .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 = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRF_RK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRF_RK', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SSYTRF_RK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rk;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 15
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_slasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_ssytf2_rk( uplo, k, a, lda, e, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! no need to adjust ipiv
! apply permutations to the leading panel 1:k-1
! read ipiv from the last block factored, i.e.
! indices k-kb+1:k and apply row permutations to the
! last k+1 colunms k+1:n after that block
! (we can do the simple loop over ipiv with decrement -1,
! since the abs value of ipiv( i ) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
if( k<n ) then
do i = k, ( k - kb + 1 ), -1
ip = abs( ipiv( i ) )
if( ip/=i ) then
call stdlib${ii}$_sswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda )
end if
end do
end if
! decrease k and return to the start of the main loop
k = k - kb
go to 10
! this label is the exit from main loop over k decreasing
! from n to 1 in steps of kb
15 continue
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rk;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 35
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_slasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), &
work, ldwork, iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_ssytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do i = k, k + kb - 1
if( ipiv( i )>0_${ik}$ ) then
ipiv( i ) = ipiv( i ) + k - 1_${ik}$
else
ipiv( i ) = ipiv( i ) - k + 1_${ik}$
end if
end do
! apply permutations to the leading panel 1:k-1
! read ipiv from the last block factored, i.e.
! indices k:k+kb-1 and apply row permutations to the
! first k-1 colunms 1:k-1 before that block
! (we can do the simple loop over ipiv with increment 1,
! since the abs value of ipiv( i ) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
if( k>1_${ik}$ ) then
do i = k, ( k + kb - 1 ), 1
ip = abs( ipiv( i ) )
if( ip/=i ) then
call stdlib${ii}$_sswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end do
end if
! increase k and return to the start of the main loop
k = k + kb
go to 20
! this label is the exit from main loop over k increasing
! from 1 to n in steps of kb
35 continue
! end lower
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssytrf_rk
pure module subroutine stdlib${ii}$_dsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
!! DSYTRF_RK computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
!! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
!! For more information see Further Details section.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, ip, iws, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .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 = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF_RK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRF_RK', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DSYTRF_RK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**t using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rk;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 15
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_dlasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_dsytf2_rk( uplo, k, a, lda, e, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! no need to adjust ipiv
! apply permutations to the leading panel 1:k-1
! read ipiv from the last block factored, i.e.
! indices k-kb+1:k and apply row permutations to the
! last k+1 colunms k+1:n after that block
! (we can do the simple loop over ipiv with decrement -1,
! since the abs value of ipiv( i ) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
if( k<n ) then
do i = k, ( k - kb + 1 ), -1
ip = abs( ipiv( i ) )
if( ip/=i ) then
call stdlib${ii}$_dswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda )
end if
end do
end if
! decrease k and return to the start of the main loop
k = k - kb
go to 10
! this label is the exit from main loop over k decreasing
! from n to 1 in steps of kb
15 continue
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rk;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 35
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_dlasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), &
work, ldwork, iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_dsytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do i = k, k + kb - 1
if( ipiv( i )>0_${ik}$ ) then
ipiv( i ) = ipiv( i ) + k - 1_${ik}$
else
ipiv( i ) = ipiv( i ) - k + 1_${ik}$
end if
end do
! apply permutations to the leading panel 1:k-1
! read ipiv from the last block factored, i.e.
! indices k:k+kb-1 and apply row permutations to the
! first k-1 colunms 1:k-1 before that block
! (we can do the simple loop over ipiv with increment 1,
! since the abs value of ipiv( i ) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
if( k>1_${ik}$ ) then
do i = k, ( k + kb - 1 ), 1
ip = abs( ipiv( i ) )
if( ip/=i ) then
call stdlib${ii}$_dswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end do
end if
! increase k and return to the start of the main loop
k = k + kb
go to 20
! this label is the exit from main loop over k increasing
! from 1 to n in steps of kb
35 continue
! end lower
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsytrf_rk
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
!! DSYTRF_RK: computes the factorization of a real symmetric matrix A
!! using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
!! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
!! For more information see Further Details section.
! -- 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
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(