#: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(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}$_${ri}$lasyf_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}$_${ri}$lasyf_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}$_${ri}$sytf2_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}$_${ri}$swap( 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}$_${ri}$lasyf_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}$_${ri}$lasyf_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}$_${ri}$sytf2_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}$_${ri}$swap( 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}$_${ri}$sytrf_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
!! CSYTRF_RK computes the factorization of a complex 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(*)
complex(sp), intent(inout) :: a(lda,*)
complex(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}$, 'CSYTRF_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( 'CSYTRF_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}$, 'CSYTRF_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}$_clasyf_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}$_clasyf_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}$_csytf2_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}$_cswap( 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}$_clasyf_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}$_clasyf_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}$_csytf2_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}$_cswap( 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}$_csytrf_rk
pure module subroutine stdlib${ii}$_zsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
!! ZSYTRF_RK computes the factorization of a complex 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(*)
complex(dp), intent(inout) :: a(lda,*)
complex(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}$, 'ZSYTRF_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( 'ZSYTRF_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}$, 'ZSYTRF_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}$_zlasyf_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}$_zlasyf_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}$_zsytf2_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}$_zswap( 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}$_zlasyf_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}$_zlasyf_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}$_zsytf2_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}$_zswap( 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}$_zsytrf_rk
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
!! ZSYTRF_RK: computes the factorization of a complex 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_${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) :: 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}$, 'ZSYTRF_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( 'ZSYTRF_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}$, 'ZSYTRF_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}$_${ci}$lasyf_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}$_${ci}$lasyf_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}$_${ci}$sytf2_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}$_${ci}$swap( 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}$_${ci}$lasyf_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}$_${ci}$lasyf_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}$_${ci}$sytf2_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}$_${ci}$swap( 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}$_${ci}$sytrf_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info )
!! SLASYF_RK 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_RK is an auxiliary routine called by SSYTRF_RK. 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) :: e(*), w(ldw,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, 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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = zero
! 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}$ )
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = zero
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
! store the superdiagonal element of d in array e
e( k ) = zero
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 diagonal elements of d(k) to a,
! copy superdiagonal element of d(k) to e(k) and
! zero out superdiagonal entry of a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = zero
a( k, k ) = w( k, kw )
e( k ) = w( k-1, kw )
e( k-1 ) = zero
end if
! end column k is nonsingular
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
! 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
! initialize the unused last entry of the subdiagonal array e.
e( n ) = zero
! 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}$ )
! set e( k ) to zero
if( k<n )e( k ) = zero
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
! store the subdiagonal element of d in array e
e( k ) = zero
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 diagonal elements of d(k) to a,
! copy subdiagonal element of d(k) to e(k) and
! zero out subdiagonal entry of a
a( k, k ) = w( k, k )
a( k+1, k ) = zero
a( k+1, k+1 ) = w( k+1, k+1 )
e( k ) = w( k+1, k )
e( k+1 ) = zero
end if
! end column k is nonsingular
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
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_slasyf_rk
pure module subroutine stdlib${ii}$_dlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info )
!! DLASYF_RK 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_RK is an auxiliary routine called by DSYTRF_RK. 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) :: e(*), w(ldw,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, 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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = zero
! 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}$ )
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = zero
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
! store the superdiagonal element of d in array e
e( k ) = zero
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 diagonal elements of d(k) to a,
! copy superdiagonal element of d(k) to e(k) and
! zero out superdiagonal entry of a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = zero
a( k, k ) = w( k, kw )
e( k ) = w( k-1, kw )
e( k-1 ) = zero
end if
! end column k is nonsingular
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
! 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
! initialize the unused last entry of the subdiagonal array e.
e( n ) = zero
! 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}$ )
! set e( k ) to zero
if( k<n )e( k ) = zero
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
! store the subdiagonal element of d in array e
e( k ) = zero
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 diagonal elements of d(k) to a,
! copy subdiagonal element of d(k) to e(k) and
! zero out subdiagonal entry of a
a( k, k ) = w( k, k )
a( k+1, k ) = zero
a( k+1, k+1 ) = w( k+1, k+1 )
e( k ) = w( k+1, k )
e( k+1 ) = zero
end if
! end column k is nonsingular
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
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_dlasyf_rk
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info )
!! DLASYF_RK: 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_RK is an auxiliary routine called by DSYTRF_RK. 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) :: e(*), w(ldw,*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: sevten = 17.0e+0_${rk}$
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, 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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = zero
! 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}$ )
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = zero
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
! store the superdiagonal element of d in array e
e( k ) = zero
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 diagonal elements of d(k) to a,
! copy superdiagonal element of d(k) to e(k) and
! zero out superdiagonal entry of a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = zero
a( k, k ) = w( k, kw )
e( k ) = w( k-1, kw )
e( k-1 ) = zero
end if
! end column k is nonsingular
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
! 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
! initialize the unused last entry of the subdiagonal array e.
e( n ) = zero
! 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}$ )
! set e( k ) to zero
if( k<n )e( k ) = zero
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
! store the subdiagonal element of d in array e
e( k ) = zero
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 diagonal elements of d(k) to a,
! copy subdiagonal element of d(k) to e(k) and
! zero out subdiagonal entry of a
a( k, k ) = w( k, k )
a( k+1, k ) = zero
a( k+1, k+1 ) = w( k+1, k+1 )
e( k ) = w( k+1, k )
e( k+1 ) = zero
end if
! end column k is nonsingular
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
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_${ri}$lasyf_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info )
!! CLASYF_RK 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_RK is an auxiliary routine called by CSYTRF_RK. 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) :: e(*), w(ldw,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, k, kk, kw, kkw, kp, kstep, p, ii
real(sp) :: absakk, alpha, colmax, rowmax, sfmin, stemp
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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = czero
! 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}$ )
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = czero
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
! store the superdiagonal element of d in array e
e( k ) = czero
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 diagonal elements of d(k) to a,
! copy superdiagonal element of d(k) to e(k) and
! zero out superdiagonal entry of a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = czero
a( k, k ) = w( k, kw )
e( k ) = w( k-1, kw )
e( k-1 ) = czero
end if
! end column k is nonsingular
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
! 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
! initialize the unused last entry of the subdiagonal array e.
e( n ) = czero
! 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}$ )
! set e( k ) to zero
if( k<n )e( k ) = czero
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
! store the subdiagonal element of d in array e
e( k ) = czero
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 diagonal elements of d(k) to a,
! copy subdiagonal element of d(k) to e(k) and
! zero out subdiagonal entry of a
a( k, k ) = w( k, k )
a( k+1, k ) = czero
a( k+1, k+1 ) = w( k+1, k+1 )
e( k ) = w( k+1, k )
e( k+1 ) = czero
end if
! end column k is nonsingular
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
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_clasyf_rk
pure module subroutine stdlib${ii}$_zlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info )
!! ZLASYF_RK 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_RK is an auxiliary routine called by ZSYTRF_RK. 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) :: e(*), w(ldw,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, k, kk, kw, kkw, kp, kstep, p, ii
real(dp) :: absakk, alpha, colmax, rowmax, sfmin, dtemp
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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = czero
! 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}$ )
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = czero
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
! store the superdiagonal element of d in array e
e( k ) = czero
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 diagonal elements of d(k) to a,
! copy superdiagonal element of d(k) to e(k) and
! zero out superdiagonal entry of a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = czero
a( k, k ) = w( k, kw )
e( k ) = w( k-1, kw )
e( k-1 ) = czero
end if
! end column k is nonsingular
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
! 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
! initialize the unused last entry of the subdiagonal array e.
e( n ) = czero
! 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}$ )
! set e( k ) to zero
if( k<n )e( k ) = czero
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
! store the subdiagonal element of d in array e
e( k ) = czero
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 diagonal elements of d(k) to a,
! copy subdiagonal element of d(k) to e(k) and
! zero out subdiagonal entry of a
a( k, k ) = w( k, k )
a( k+1, k ) = czero
a( k+1, k+1 ) = w( k+1, k+1 )
e( k ) = w( k+1, k )
e( k+1 ) = czero
end if
! end column k is nonsingular
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
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_zlasyf_rk
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info )
!! ZLASYF_RK: 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_RK is an auxiliary routine called by ZSYTRF_RK. 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) :: e(*), w(ldw,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$
! Local Scalars
logical(lk) :: done
integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, k, kk, kw, kkw, kp, kstep, p, ii
real(${ck}$) :: absakk, alpha, colmax, rowmax, sfmin, dtemp
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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = czero
! 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}$ )
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = czero
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
! store the superdiagonal element of d in array e
e( k ) = czero
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 diagonal elements of d(k) to a,
! copy superdiagonal element of d(k) to e(k) and
! zero out superdiagonal entry of a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = czero
a( k, k ) = w( k, kw )
e( k ) = w( k-1, kw )
e( k-1 ) = czero
end if
! end column k is nonsingular
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
! 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
! initialize the unused last entry of the subdiagonal array e.
e( n ) = czero
! 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}$ )
! set e( k ) to zero
if( k<n )e( k ) = czero
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
! store the subdiagonal element of d in array e
e( k ) = czero
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 diagonal elements of d(k) to a,
! copy subdiagonal element of d(k) to e(k) and
! zero out subdiagonal entry of a
a( k, k ) = w( k, k )
a( k+1, k ) = czero
a( k+1, k+1 ) = w( k+1, k+1 )
e( k ) = w( k+1, k )
e( k+1 ) = czero
end if
! end column k is nonsingular
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
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_${ci}$lasyf_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytf2_rk( uplo, n, a, lda, e, ipiv, info )
!! SSYTF2_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 unblocked version of the algorithm, calling Level 2 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, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: e(*)
! =====================================================================
! 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_RK', -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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = zero
! 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 34
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
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = zero
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_sswap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_sswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
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
! store the superdiagonal element of d in array e
e( k ) = zero
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
! copy superdiagonal elements of d(k) to e(k) and
! zero out superdiagonal entry of a
e( k ) = a( k-1, k )
e( k-1 ) = zero
a( k-1, k ) = zero
end if
! end column k is nonsingular
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
34 continue
else
! factorize a as l*d*l**t using the lower triangle of a
! initialize the unused last entry of the subdiagonal array e.
e( n ) = zero
! 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 64
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
! set e( k ) to zero
if( k<n )e( k ) = zero
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_sswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_sswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
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
! store the subdiagonal element of d in array e
e( k ) = zero
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
! copy subdiagonal elements of d(k) to e(k) and
! zero out subdiagonal entry of a
e( k ) = a( k+1, k )
e( k+1 ) = zero
a( k+1, k ) = zero
end if
! end column k is nonsingular
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
64 continue
end if
return
end subroutine stdlib${ii}$_ssytf2_rk
pure module subroutine stdlib${ii}$_dsytf2_rk( uplo, n, a, lda, e, ipiv, info )
!! DSYTF2_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 unblocked version of the algorithm, calling Level 2 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, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: e(*)
! =====================================================================
! 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_RK', -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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = zero
! 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 34
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
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = zero
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_dswap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_dswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
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
! store the superdiagonal element of d in array e
e( k ) = zero
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
! copy superdiagonal elements of d(k) to e(k) and
! zero out superdiagonal entry of a
e( k ) = a( k-1, k )
e( k-1 ) = zero
a( k-1, k ) = zero
end if
! end column k is nonsingular
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
34 continue
else
! factorize a as l*d*l**t using the lower triangle of a
! initialize the unused last entry of the subdiagonal array e.
e( n ) = zero
! 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 64
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
! set e( k ) to zero
if( k<n )e( k ) = zero
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_dswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_dswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
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
! store the subdiagonal element of d in array e
e( k ) = zero
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
! copy subdiagonal elements of d(k) to e(k) and
! zero out subdiagonal entry of a
e( k ) = a( k+1, k )
e( k+1 ) = zero
a( k+1, k ) = zero
end if
! end column k is nonsingular
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
64 continue
end if
return
end subroutine stdlib${ii}$_dsytf2_rk
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytf2_rk( uplo, n, a, lda, e, ipiv, info )
!! DSYTF2_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 unblocked version of the algorithm, calling Level 2 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, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: e(*)
! =====================================================================
! 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_RK', -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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = zero
! 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 34
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
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = zero
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_${ri}$swap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_${ri}$swap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
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
! store the superdiagonal element of d in array e
e( k ) = zero
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
! copy superdiagonal elements of d(k) to e(k) and
! zero out superdiagonal entry of a
e( k ) = a( k-1, k )
e( k-1 ) = zero
a( k-1, k ) = zero
end if
! end column k is nonsingular
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
34 continue
else
! factorize a as l*d*l**t using the lower triangle of a
! initialize the unused last entry of the subdiagonal array e.
e( n ) = zero
! 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 64
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
! set e( k ) to zero
if( k<n )e( k ) = zero
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_${ri}$swap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_${ri}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
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
! store the subdiagonal element of d in array e
e( k ) = zero
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
! copy subdiagonal elements of d(k) to e(k) and
! zero out subdiagonal entry of a
e( k ) = a( k+1, k )
e( k+1 ) = zero
a( k+1, k ) = zero
end if
! end column k is nonsingular
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
64 continue
end if
return
end subroutine stdlib${ii}$_${ri}$sytf2_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytf2_rk( uplo, n, a, lda, e, ipiv, info )
!! CSYTF2_RK computes the factorization of a complex 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 unblocked version of the algorithm, calling Level 2 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, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: e(*)
! =====================================================================
! 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_RK', -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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = czero
! 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 34
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
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = czero
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)
! abs( 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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_cswap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_cswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
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
! store the superdiagonal element of d in array e
e( k ) = czero
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
! copy superdiagonal elements of d(k) to e(k) and
! zero out superdiagonal entry of a
e( k ) = a( k-1, k )
e( k-1 ) = czero
a( k-1, k ) = czero
end if
! end column k is nonsingular
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
34 continue
else
! factorize a as l*d*l**t using the lower triangle of a
! initialize the unused last entry of the subdiagonal array e.
e( n ) = czero
! 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 64
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
! set e( k ) to zero
if( k<n )e( k ) = czero
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)
! abs( 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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
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
! store the subdiagonal element of d in array e
e( k ) = czero
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
! copy subdiagonal elements of d(k) to e(k) and
! zero out subdiagonal entry of a
e( k ) = a( k+1, k )
e( k+1 ) = czero
a( k+1, k ) = czero
end if
! end column k is nonsingular
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
64 continue
end if
return
end subroutine stdlib${ii}$_csytf2_rk
pure module subroutine stdlib${ii}$_zsytf2_rk( uplo, n, a, lda, e, ipiv, info )
!! ZSYTF2_RK computes the factorization of a complex 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 unblocked version of the algorithm, calling Level 2 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, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: e(*)
! =====================================================================
! 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_RK', -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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = czero
! 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 34
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
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = czero
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)
! abs( 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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_zswap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_zswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
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
! store the superdiagonal element of d in array e
e( k ) = czero
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
! copy superdiagonal elements of d(k) to e(k) and
! zero out superdiagonal entry of a
e( k ) = a( k-1, k )
e( k-1 ) = czero
a( k-1, k ) = czero
end if
! end column k is nonsingular
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
34 continue
else
! factorize a as l*d*l**t using the lower triangle of a
! initialize the unused last entry of the subdiagonal array e.
e( n ) = czero
! 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 64
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
! set e( k ) to zero
if( k<n )e( k ) = czero
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)
! abs( 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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
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
! store the subdiagonal element of d in array e
e( k ) = czero
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
! copy subdiagonal elements of d(k) to e(k) and
! zero out subdiagonal entry of a
e( k ) = a( k+1, k )
e( k+1 ) = czero
a( k+1, k ) = czero
end if
! end column k is nonsingular
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
64 continue
end if
return
end subroutine stdlib${ii}$_zsytf2_rk
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytf2_rk( uplo, n, a, lda, e, ipiv, info )
!! ZSYTF2_RK: computes the factorization of a complex 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 unblocked version of the algorithm, calling Level 2 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_${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,*)
complex(${ck}$), intent(out) :: e(*)
! =====================================================================
! 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_RK', -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
! initialize the first entry of array e, where superdiagonal
! elements of d are stored
e( 1_${ik}$ ) = czero
! 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 34
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
! set e( k ) to zero
if( k>1_${ik}$ )e( k ) = czero
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)
! abs( 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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_${ci}$swap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
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
! convert upper triangle of a into u form by applying
! the interchanges in columns k+1:n.
if( k<n )call stdlib${ii}$_${ci}$swap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
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
! store the superdiagonal element of d in array e
e( k ) = czero
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
! copy superdiagonal elements of d(k) to e(k) and
! zero out superdiagonal entry of a
e( k ) = a( k-1, k )
e( k-1 ) = czero
a( k-1, k ) = czero
end if
! end column k is nonsingular
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
34 continue
else
! factorize a as l*d*l**t using the lower triangle of a
! initialize the unused last entry of the subdiagonal array e.
e( n ) = czero
! 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 64
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
! set e( k ) to zero
if( k<n )e( k ) = czero
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)
! abs( 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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
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
! convert lower triangle of a into l form by applying
! the interchanges in columns 1:k-1.
if ( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
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
! store the subdiagonal element of d in array e
e( k ) = czero
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
! copy subdiagonal elements of d(k) to e(k) and
! zero out subdiagonal entry of a
e( k ) = a( k+1, k )
e( k+1 ) = czero
a( k+1, k ) = czero
end if
! end column k is nonsingular
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
64 continue
end if
return
end subroutine stdlib${ii}$_${ci}$sytf2_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssyconvf( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! SSYCONVF converts the factorization output format used in
!! SSYTRF provided on entry in parameter A into the factorization
!! output format used in SSYTRF_RK (or SSYTRF_BK) that is stored
!! on exit in parameters A and E. It also converts in place details of
!! the intechanges stored in IPIV from the format used in SSYTRF into
!! the format used in SSYTRF_RK (or SSYTRF_BK).
!! If parameter WAY = 'R':
!! SSYCONVF performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in SSYTRF_RK
!! (or SSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in SSYTRF that is stored
!! on exit in parameter A. It also converts in place details of
!! the intechanges stored in IPIV from the format used in SSYTRF_RK
!! (or SSYTRF_BK) into the format used in SSYTRF.
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYCONVF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = zero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = zero
a( i-1, i ) = zero
i = i - 1_${ik}$
else
e( i ) = zero
end if
i = i - 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_sswap( n-i, a( i-1, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_sswap( n-i, a( ip, i+1 ), lda,a( i-1, i+1 ), lda )
end if
end if
! convert ipiv
! there is one interchange of rows i-1 and ipiv(i-1),
! so this should be recorded in two consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i-1 )
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = zero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = zero
a( i+1, i ) = zero
i = i + 1_${ik}$
else
e( i ) = zero
end if
i = i + 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in factorization order where k increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_sswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_sswap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is one interchange of rows i+1 and ipiv(i+1),
! so this should be recorded in consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i+1 )
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_ssyconvf
pure module subroutine stdlib${ii}$_dsyconvf( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! DSYCONVF converts the factorization output format used in
!! DSYTRF provided on entry in parameter A into the factorization
!! output format used in DSYTRF_RK (or DSYTRF_BK) that is stored
!! on exit in parameters A and E. It also converts in place details of
!! the intechanges stored in IPIV from the format used in DSYTRF into
!! the format used in DSYTRF_RK (or DSYTRF_BK).
!! If parameter WAY = 'R':
!! DSYCONVF performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in DSYTRF_RK
!! (or DSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in DSYTRF that is stored
!! on exit in parameter A. It also converts in place details of
!! the intechanges stored in IPIV from the format used in DSYTRF_RK
!! (or DSYTRF_BK) into the format used in DSYTRF.
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYCONVF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = zero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = zero
a( i-1, i ) = zero
i = i - 1_${ik}$
else
e( i ) = zero
end if
i = i - 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_dswap( n-i, a( i-1, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_dswap( n-i, a( ip, i+1 ), lda,a( i-1, i+1 ), lda )
end if
end if
! convert ipiv
! there is one interchange of rows i-1 and ipiv(i-1),
! so this should be recorded in two consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i-1 )
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = zero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = zero
a( i+1, i ) = zero
i = i + 1_${ik}$
else
e( i ) = zero
end if
i = i + 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in factorization order where k increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_dswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_dswap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is one interchange of rows i+1 and ipiv(i+1),
! so this should be recorded in consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i+1 )
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_dsyconvf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$syconvf( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! DSYCONVF: converts the factorization output format used in
!! DSYTRF provided on entry in parameter A into the factorization
!! output format used in DSYTRF_RK (or DSYTRF_BK) that is stored
!! on exit in parameters A and E. It also converts in place details of
!! the intechanges stored in IPIV from the format used in DSYTRF into
!! the format used in DSYTRF_RK (or DSYTRF_BK).
!! If parameter WAY = 'R':
!! DSYCONVF performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in DSYTRF_RK
!! (or DSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in DSYTRF that is stored
!! on exit in parameter A. It also converts in place details of
!! the intechanges stored in IPIV from the format used in DSYTRF_RK
!! (or DSYTRF_BK) into the format used in DSYTRF.
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYCONVF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = zero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = zero
a( i-1, i ) = zero
i = i - 1_${ik}$
else
e( i ) = zero
end if
i = i - 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_${ri}$swap( n-i, a( i-1, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_${ri}$swap( n-i, a( ip, i+1 ), lda,a( i-1, i+1 ), lda )
end if
end if
! convert ipiv
! there is one interchange of rows i-1 and ipiv(i-1),
! so this should be recorded in two consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i-1 )
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = zero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = zero
a( i+1, i ) = zero
i = i + 1_${ik}$
else
e( i ) = zero
end if
i = i + 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in factorization order where k increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_${ri}$swap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_${ri}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is one interchange of rows i+1 and ipiv(i+1),
! so this should be recorded in consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i+1 )
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_${ri}$syconvf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csyconvf( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! CSYCONVF converts the factorization output format used in
!! CSYTRF provided on entry in parameter A into the factorization
!! output format used in CSYTRF_RK (or CSYTRF_BK) that is stored
!! on exit in parameters A and E. It also converts in place details of
!! the intechanges stored in IPIV from the format used in CSYTRF into
!! the format used in CSYTRF_RK (or CSYTRF_BK).
!! If parameter WAY = 'R':
!! CSYCONVF performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in CSYTRF_RK
!! (or CSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in CSYTRF that is stored
!! on exit in parameter A. It also converts in place details of
!! the intechanges stored in IPIV from the format used in CSYTRF_RK
!! (or CSYTRF_BK) into the format used in CSYTRF.
!! CSYCONVF can also convert in Hermitian matrix case, i.e. between
!! formats used in CHETRF and CHETRF_RK (or CHETRF_BK).
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYCONVF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = czero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = czero
a( i-1, i ) = czero
i = i - 1_${ik}$
else
e( i ) = czero
end if
i = i - 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_cswap( n-i, a( i-1, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_cswap( n-i, a( ip, i+1 ), lda,a( i-1, i+1 ), lda )
end if
end if
! convert ipiv
! there is cone interchange of rows i-1 and ipiv(i-1),
! so this should be recorded in two consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i-1 )
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = czero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = czero
a( i+1, i ) = czero
i = i + 1_${ik}$
else
e( i ) = czero
end if
i = i + 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in factorization order where k increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_cswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_cswap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is cone interchange of rows i+1 and ipiv(i+1),
! so this should be recorded in consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i+1 )
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_csyconvf
pure module subroutine stdlib${ii}$_zsyconvf( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! ZSYCONVF converts the factorization output format used in
!! ZSYTRF provided on entry in parameter A into the factorization
!! output format used in ZSYTRF_RK (or ZSYTRF_BK) that is stored
!! on exit in parameters A and E. It also converts in place details of
!! the intechanges stored in IPIV from the format used in ZSYTRF into
!! the format used in ZSYTRF_RK (or ZSYTRF_BK).
!! If parameter WAY = 'R':
!! ZSYCONVF performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in ZSYTRF_RK
!! (or ZSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in ZSYTRF that is stored
!! on exit in parameter A. It also converts in place details of
!! the intechanges stored in IPIV from the format used in ZSYTRF_RK
!! (or ZSYTRF_BK) into the format used in ZSYTRF.
!! ZSYCONVF can also convert in Hermitian matrix case, i.e. between
!! formats used in ZHETRF and ZHETRF_RK (or ZHETRF_BK).
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYCONVF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = czero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = czero
a( i-1, i ) = czero
i = i - 1_${ik}$
else
e( i ) = czero
end if
i = i - 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_zswap( n-i, a( i-1, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_zswap( n-i, a( ip, i+1 ), lda,a( i-1, i+1 ), lda )
end if
end if
! convert ipiv
! there is cone interchange of rows i-1 and ipiv(i-1),
! so this should be recorded in two consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i-1 )
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = czero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = czero
a( i+1, i ) = czero
i = i + 1_${ik}$
else
e( i ) = czero
end if
i = i + 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in factorization order where k increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_zswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_zswap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is cone interchange of rows i+1 and ipiv(i+1),
! so this should be recorded in consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i+1 )
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_zsyconvf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$syconvf( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! ZSYCONVF: converts the factorization output format used in
!! ZSYTRF provided on entry in parameter A into the factorization
!! output format used in ZSYTRF_RK (or ZSYTRF_BK) that is stored
!! on exit in parameters A and E. It also converts in place details of
!! the intechanges stored in IPIV from the format used in ZSYTRF into
!! the format used in ZSYTRF_RK (or ZSYTRF_BK).
!! If parameter WAY = 'R':
!! ZSYCONVF performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in ZSYTRF_RK
!! (or ZSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in ZSYTRF that is stored
!! on exit in parameter A. It also converts in place details of
!! the intechanges stored in IPIV from the format used in ZSYTRF_RK
!! (or ZSYTRF_BK) into the format used in ZSYTRF.
!! ZSYCONVF can also convert in Hermitian matrix case, i.e. between
!! formats used in ZHETRF and ZHETRF_RK (or ZHETRF_BK).
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYCONVF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = czero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = czero
a( i-1, i ) = czero
i = i - 1_${ik}$
else
e( i ) = czero
end if
i = i - 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_${ci}$swap( n-i, a( i-1, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations and ipiv
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i) in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
if( i<n ) then
if( ip/=(i-1) ) then
call stdlib${ii}$_${ci}$swap( n-i, a( ip, i+1 ), lda,a( i-1, i+1 ), lda )
end if
end if
! convert ipiv
! there is cone interchange of rows i-1 and ipiv(i-1),
! so this should be recorded in two consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i-1 )
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = czero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = czero
a( i+1, i ) = czero
i = i + 1_${ik}$
else
e( i ) = czero
end if
i = i + 1_${ik}$
end do
! convert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in factorization order where k increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_${ci}$swap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is no interchnge of rows i and and ipiv(i),
! so this should be reflected in ipiv format for
! *sytrf_rk ( or *sytrf_bk)
ipiv( i ) = i
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations and ipiv
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i) in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=(i+1) ) then
call stdlib${ii}$_${ci}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
end if
! convert ipiv
! there is cone interchange of rows i+1 and ipiv(i+1),
! so this should be recorded in consecutive entries
! in ipiv format for *sytrf
ipiv( i ) = ipiv( i+1 )
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_${ci}$syconvf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssyconvf_rook( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! SSYCONVF_ROOK converts the factorization output format used in
!! SSYTRF_ROOK provided on entry in parameter A into the factorization
!! output format used in SSYTRF_RK (or SSYTRF_BK) that is stored
!! on exit in parameters A and E. IPIV format for SSYTRF_ROOK and
!! SSYTRF_RK (or SSYTRF_BK) is the same and is not converted.
!! If parameter WAY = 'R':
!! SSYCONVF_ROOK performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in SSYTRF_RK
!! (or SSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in SSYTRF_ROOK that is stored
!! on exit in parameter A. IPIV format for SSYTRF_ROOK and
!! SSYTRF_RK (or SSYTRF_BK) is the same and is not converted.
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip, ip2
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYCONVF_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = zero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = zero
a( i-1, i ) = zero
i = i - 1_${ik}$
else
e( i ) = zero
end if
i = i - 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i-1 and ipiv(i-1)
! in a(1:i,n-i:n)
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
if( ip2/=(i-1) ) then
call stdlib${ii}$_sswap( n-i, a( i-1, i+1 ), lda,a( ip2, i+1 ), lda )
end if
end if
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i-1) and i and ipiv(i)
! in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip2/=(i-1) ) then
call stdlib${ii}$_sswap( n-i, a( ip2, i+1 ), lda,a( i-1, i+1 ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_sswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = zero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = zero
a( i+1, i ) = zero
i = i + 1_${ik}$
else
e( i ) = zero
end if
i = i + 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of lower part of a
! in factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i+1 and ipiv(i+1)
! in a(i:n,1:i-1)
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
if( ip2/=(i+1) ) then
call stdlib${ii}$_sswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip2, 1_${ik}$ ), lda )
end if
end if
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_sswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i+1) and i and ipiv(i)
! in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip2/=(i+1) ) then
call stdlib${ii}$_sswap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_sswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_ssyconvf_rook
pure module subroutine stdlib${ii}$_dsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! DSYCONVF_ROOK converts the factorization output format used in
!! DSYTRF_ROOK provided on entry in parameter A into the factorization
!! output format used in DSYTRF_RK (or DSYTRF_BK) that is stored
!! on exit in parameters A and E. IPIV format for DSYTRF_ROOK and
!! DSYTRF_RK (or DSYTRF_BK) is the same and is not converted.
!! If parameter WAY = 'R':
!! DSYCONVF_ROOK performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in DSYTRF_RK
!! (or DSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in DSYTRF_ROOK that is stored
!! on exit in parameter A. IPIV format for DSYTRF_ROOK and
!! DSYTRF_RK (or DSYTRF_BK) is the same and is not converted.
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip, ip2
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYCONVF_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = zero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = zero
a( i-1, i ) = zero
i = i - 1_${ik}$
else
e( i ) = zero
end if
i = i - 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i-1 and ipiv(i-1)
! in a(1:i,n-i:n)
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
if( ip2/=(i-1) ) then
call stdlib${ii}$_dswap( n-i, a( i-1, i+1 ), lda,a( ip2, i+1 ), lda )
end if
end if
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i-1) and i and ipiv(i)
! in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip2/=(i-1) ) then
call stdlib${ii}$_dswap( n-i, a( ip2, i+1 ), lda,a( i-1, i+1 ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_dswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = zero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = zero
a( i+1, i ) = zero
i = i + 1_${ik}$
else
e( i ) = zero
end if
i = i + 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of lower part of a
! in factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i+1 and ipiv(i+1)
! in a(i:n,1:i-1)
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
if( ip2/=(i+1) ) then
call stdlib${ii}$_dswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip2, 1_${ik}$ ), lda )
end if
end if
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_dswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i+1) and i and ipiv(i)
! in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip2/=(i+1) ) then
call stdlib${ii}$_dswap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_dswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_dsyconvf_rook
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$syconvf_rook( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! DSYCONVF_ROOK: converts the factorization output format used in
!! DSYTRF_ROOK provided on entry in parameter A into the factorization
!! output format used in DSYTRF_RK (or DSYTRF_BK) that is stored
!! on exit in parameters A and E. IPIV format for DSYTRF_ROOK and
!! DSYTRF_RK (or DSYTRF_BK) is the same and is not converted.
!! If parameter WAY = 'R':
!! DSYCONVF_ROOK performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in DSYTRF_RK
!! (or DSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in DSYTRF_ROOK that is stored
!! on exit in parameter A. IPIV format for DSYTRF_ROOK and
!! DSYTRF_RK (or DSYTRF_BK) is the same and is not converted.
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip, ip2
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYCONVF_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = zero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = zero
a( i-1, i ) = zero
i = i - 1_${ik}$
else
e( i ) = zero
end if
i = i - 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i-1 and ipiv(i-1)
! in a(1:i,n-i:n)
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
if( ip2/=(i-1) ) then
call stdlib${ii}$_${ri}$swap( n-i, a( i-1, i+1 ), lda,a( ip2, i+1 ), lda )
end if
end if
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i-1) and i and ipiv(i)
! in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip2/=(i-1) ) then
call stdlib${ii}$_${ri}$swap( n-i, a( ip2, i+1 ), lda,a( i-1, i+1 ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and zero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = zero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = zero
a( i+1, i ) = zero
i = i + 1_${ik}$
else
e( i ) = zero
end if
i = i + 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of lower part of a
! in factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i+1 and ipiv(i+1)
! in a(i:n,1:i-1)
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
if( ip2/=(i+1) ) then
call stdlib${ii}$_${ri}$swap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip2, 1_${ik}$ ), lda )
end if
end if
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i+1) and i and ipiv(i)
! in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip2/=(i+1) ) then
call stdlib${ii}$_${ri}$swap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_${ri}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_${ri}$syconvf_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csyconvf_rook( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! CSYCONVF_ROOK converts the factorization output format used in
!! CSYTRF_ROOK provided on entry in parameter A into the factorization
!! output format used in CSYTRF_RK (or CSYTRF_BK) that is stored
!! on exit in parameters A and E. IPIV format for CSYTRF_ROOK and
!! CSYTRF_RK (or CSYTRF_BK) is the same and is not converted.
!! If parameter WAY = 'R':
!! CSYCONVF_ROOK performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in CSYTRF_RK
!! (or CSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in CSYTRF_ROOK that is stored
!! on exit in parameter A. IPIV format for CSYTRF_ROOK and
!! CSYTRF_RK (or CSYTRF_BK) is the same and is not converted.
!! CSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between
!! formats used in CHETRF_ROOK and CHETRF_RK (or CHETRF_BK).
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip, ip2
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYCONVF_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = czero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = czero
a( i-1, i ) = czero
i = i - 1_${ik}$
else
e( i ) = czero
end if
i = i - 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i-1 and ipiv(i-1)
! in a(1:i,n-i:n)
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
if( ip2/=(i-1) ) then
call stdlib${ii}$_cswap( n-i, a( i-1, i+1 ), lda,a( ip2, i+1 ), lda )
end if
end if
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i-1) and i and ipiv(i)
! in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip2/=(i-1) ) then
call stdlib${ii}$_cswap( n-i, a( ip2, i+1 ), lda,a( i-1, i+1 ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_cswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = czero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = czero
a( i+1, i ) = czero
i = i + 1_${ik}$
else
e( i ) = czero
end if
i = i + 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of lower part of a
! in factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i+1 and ipiv(i+1)
! in a(i:n,1:i-1)
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
if( ip2/=(i+1) ) then
call stdlib${ii}$_cswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip2, 1_${ik}$ ), lda )
end if
end if
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_cswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i+1) and i and ipiv(i)
! in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip2/=(i+1) ) then
call stdlib${ii}$_cswap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_cswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_csyconvf_rook
pure module subroutine stdlib${ii}$_zsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! ZSYCONVF_ROOK converts the factorization output format used in
!! ZSYTRF_ROOK provided on entry in parameter A into the factorization
!! output format used in ZSYTRF_RK (or ZSYTRF_BK) that is stored
!! on exit in parameters A and E. IPIV format for ZSYTRF_ROOK and
!! ZSYTRF_RK (or ZSYTRF_BK) is the same and is not converted.
!! If parameter WAY = 'R':
!! ZSYCONVF_ROOK performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in ZSYTRF_RK
!! (or ZSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in ZSYTRF_ROOK that is stored
!! on exit in parameter A. IPIV format for ZSYTRF_ROOK and
!! ZSYTRF_RK (or ZSYTRF_BK) is the same and is not converted.
!! ZSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between
!! formats used in ZHETRF_ROOK and ZHETRF_RK (or ZHETRF_BK).
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip, ip2
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYCONVF_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = czero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = czero
a( i-1, i ) = czero
i = i - 1_${ik}$
else
e( i ) = czero
end if
i = i - 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i-1 and ipiv(i-1)
! in a(1:i,n-i:n)
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
if( ip2/=(i-1) ) then
call stdlib${ii}$_zswap( n-i, a( i-1, i+1 ), lda,a( ip2, i+1 ), lda )
end if
end if
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i-1) and i and ipiv(i)
! in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip2/=(i-1) ) then
call stdlib${ii}$_zswap( n-i, a( ip2, i+1 ), lda,a( i-1, i+1 ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_zswap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = czero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = czero
a( i+1, i ) = czero
i = i + 1_${ik}$
else
e( i ) = czero
end if
i = i + 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of lower part of a
! in factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i+1 and ipiv(i+1)
! in a(i:n,1:i-1)
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
if( ip2/=(i+1) ) then
call stdlib${ii}$_zswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip2, 1_${ik}$ ), lda )
end if
end if
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_zswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i+1) and i and ipiv(i)
! in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip2/=(i+1) ) then
call stdlib${ii}$_zswap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_zswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_zsyconvf_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$syconvf_rook( uplo, way, n, a, lda, e, ipiv, info )
!! If parameter WAY = 'C':
!! ZSYCONVF_ROOK: converts the factorization output format used in
!! ZSYTRF_ROOK provided on entry in parameter A into the factorization
!! output format used in ZSYTRF_RK (or ZSYTRF_BK) that is stored
!! on exit in parameters A and E. IPIV format for ZSYTRF_ROOK and
!! ZSYTRF_RK (or ZSYTRF_BK) is the same and is not converted.
!! If parameter WAY = 'R':
!! ZSYCONVF_ROOK performs the conversion in reverse direction, i.e.
!! converts the factorization output format used in ZSYTRF_RK
!! (or ZSYTRF_BK) provided on entry in parameters A and E into
!! the factorization output format used in ZSYTRF_ROOK that is stored
!! on exit in parameter A. IPIV format for ZSYTRF_ROOK and
!! ZSYTRF_RK (or ZSYTRF_BK) is the same and is not converted.
!! ZSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between
!! formats used in ZHETRF_ROOK and ZHETRF_RK (or ZHETRF_BK).
! -- 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, way
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), e(*)
! =====================================================================
! External Subroutines
logical(lk) :: upper, convert
integer(${ik}$) :: i, ip, ip2
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
convert = stdlib_lsame( way, 'C' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYCONVF_ROOK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! begin a is upper
if ( convert ) then
! convert a (a is upper)
! convert value
! assign superdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = n
e( 1_${ik}$ ) = czero
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
e( i ) = a( i-1, i )
e( i-1 ) = czero
a( i-1, i ) = czero
i = i - 1_${ik}$
else
e( i ) = czero
end if
i = i - 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of upper part of a
! in factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i-1 and ipiv(i-1)
! in a(1:i,n-i:n)
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( n-i, a( i, i+1 ), lda,a( ip, i+1 ), lda )
end if
if( ip2/=(i-1) ) then
call stdlib${ii}$_${ci}$swap( n-i, a( i-1, i+1 ), lda,a( ip2, i+1 ), lda )
end if
end if
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
else
! revert a (a is upper)
! revert permutations
! apply permutations to submatrices of upper part of a
! in reverse factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(1:i,n-i:n)
ip = ipiv( i )
if( i<n ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i-1 and ipiv(i-1) and i and ipiv(i)
! in a(1:i,n-i:n)
i = i + 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i-1 )
if( i<n ) then
if( ip2/=(i-1) ) then
call stdlib${ii}$_${ci}$swap( n-i, a( ip2, i+1 ), lda,a( i-1, i+1 ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( n-i, a( ip, i+1 ), lda,a( i, i+1 ), lda )
end if
end if
end if
i = i + 1_${ik}$
end do
! revert value
! assign superdiagonal entries of d from array e to
! superdiagonal entries of a.
i = n
do while ( i>1 )
if( ipiv( i )<0_${ik}$ ) then
a( i-1, i ) = e( i )
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! end a is upper
end if
else
! begin a is lower
if ( convert ) then
! convert a (a is lower)
! convert value
! assign subdiagonal entries of d to array e and czero out
! corresponding entries in input storage a
i = 1_${ik}$
e( n ) = czero
do while ( i<=n )
if( i<n .and. ipiv(i)<0_${ik}$ ) then
e( i ) = a( i+1, i )
e( i+1 ) = czero
a( i+1, i ) = czero
i = i + 1_${ik}$
else
e( i ) = czero
end if
i = i + 1_${ik}$
end do
! convert permutations
! apply permutations to submatrices of lower part of a
! in factorization order where i increases from 1 to n
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i and ipiv(i) and i+1 and ipiv(i+1)
! in a(i:n,1:i-1)
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
end if
if( ip2/=(i+1) ) then
call stdlib${ii}$_${ci}$swap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip2, 1_${ik}$ ), lda )
end if
end if
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
else
! revert a (a is lower)
! revert permutations
! apply permutations to submatrices of lower part of a
! in reverse factorization order where i decreases from n to 1
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
! 1-by-1 pivot interchange
! swap rows i and ipiv(i) in a(i:n,1:i-1)
ip = ipiv( i )
if ( i>1_${ik}$ ) then
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
else
! 2-by-2 pivot interchange
! swap rows i+1 and ipiv(i+1) and i and ipiv(i)
! in a(i:n,1:i-1)
i = i - 1_${ik}$
ip = -ipiv( i )
ip2 = -ipiv( i+1 )
if ( i>1_${ik}$ ) then
if( ip2/=(i+1) ) then
call stdlib${ii}$_${ci}$swap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda )
end if
if( ip/=i ) then
call stdlib${ii}$_${ci}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda )
end if
end if
end if
i = i - 1_${ik}$
end do
! revert value
! assign subdiagonal entries of d from array e to
! subgiagonal entries of a.
i = 1_${ik}$
do while ( i<=n-1 )
if( ipiv( i )<0_${ik}$ ) then
a( i + 1_${ik}$, i ) = e( i )
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
end if
! end a is lower
end if
return
end subroutine stdlib${ii}$_${ci}$syconvf_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info)
!! SSYTRF_AA computes the factorization of a real symmetric matrix A
!! using the Aasen's algorithm. The form of the factorization is
!! A = U**T*T*U or A = L*T*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is a symmetric tridiagonal matrix.
!! 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(in) :: n, lda, lwork
integer(${ik}$), intent(out) :: info
! 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}$) :: j, lwkopt
integer(${ik}$) :: nb, mj, nj, k1, k2, j1, j2, j3, jb
real(sp) :: alpha
! Intrinsic Functions
! Executable Statements
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRF_AA', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
! 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<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = (nb+1)*n
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRF_AA', -info )
return
else if( lquery ) then
return
end if
! quick return
if ( n==0_${ik}$ ) then
return
endif
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( n==1_${ik}$ ) then
return
end if
! adjust block size based on the workspace size
if( lwork<((1_${ik}$+nb)*n) ) then
nb = ( lwork-n ) / n
end if
if( upper ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n))
call stdlib${ii}$_scopy( n, a( 1_${ik}$, 1_${ik}$ ), lda, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_slasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
10 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j + 1_${ik}$
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_slasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_sswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ )
end if
end do
j = j + jb
! trailing submatrix update, where
! the row a(j1-1, j2-1:n) stores u(j1, j2+1:n) and
! work stores the current block of the auxiriarly matrix h
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j, j+1 )
a( j, j+1 ) = one
call stdlib${ii}$_scopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_sgemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), &
n,a( j1-k2, j3 ), 1_${ik}$,one, a( j3, j3 ), lda )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block of j2-th block row with stdlib${ii}$_sgemm
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-&
k2, j2 ), lda,work( j3-j1+1+k1*n ), n,one, a( j2, j3 ), lda )
end do
! recover t( j, j+1 )
a( j, j+1 ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_scopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 10
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
! copy first column a(1:n, 1) into h(1:n, 1)
! (stored in work(1:n))
call stdlib${ii}$_scopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_slasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
11 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j+1
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_slasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_sswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda )
end if
end do
j = j + jb
! trailing submatrix update, where
! a(j2+1, j1-1) stores l(j2+1, j1) and
! work(j2+1, 1) stores h(j2+1, 1)
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j+1, j )
a( j+1, j ) = one
call stdlib${ii}$_scopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_sgemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), &
n,a( j3, j1-k2 ), lda,one, a( j3, j3 ), 1_${ik}$ )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block in j2-th block column with stdlib${ii}$_sgemm
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(&
j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,one, a( j3, j2 ), lda )
end do
! recover t( j+1, j )
a( j+1, j ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_scopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 11
end if
20 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssytrf_aa
pure module subroutine stdlib${ii}$_dsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info)
!! DSYTRF_AA computes the factorization of a real symmetric matrix A
!! using the Aasen's algorithm. The form of the factorization is
!! A = U**T*T*U or A = L*T*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is a symmetric tridiagonal matrix.
!! 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(in) :: n, lda, lwork
integer(${ik}$), intent(out) :: info
! 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}$) :: j, lwkopt
integer(${ik}$) :: nb, mj, nj, k1, k2, j1, j2, j3, jb
real(dp) :: alpha
! Intrinsic Functions
! Executable Statements
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF_AA', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
! 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<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = (nb+1)*n
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRF_AA', -info )
return
else if( lquery ) then
return
end if
! quick return
if ( n==0_${ik}$ ) then
return
endif
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( n==1_${ik}$ ) then
return
end if
! adjust block size based on the workspace size
if( lwork<((1_${ik}$+nb)*n) ) then
nb = ( lwork-n ) / n
end if
if( upper ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n))
call stdlib${ii}$_dcopy( n, a( 1_${ik}$, 1_${ik}$ ), lda, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_dlasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
10 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j + 1_${ik}$
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_dlasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_dswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ )
end if
end do
j = j + jb
! trailing submatrix update, where
! the row a(j1-1, j2-1:n) stores u(j1, j2+1:n) and
! work stores the current block of the auxiriarly matrix h
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j, j+1 )
a( j, j+1 ) = one
call stdlib${ii}$_dcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_dgemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), &
n,a( j1-k2, j3 ), 1_${ik}$,one, a( j3, j3 ), lda )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block of j2-th block row with stdlib${ii}$_dgemm
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-&
k2, j2 ), lda,work( j3-j1+1+k1*n ), n,one, a( j2, j3 ), lda )
end do
! recover t( j, j+1 )
a( j, j+1 ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_dcopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 10
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
! copy first column a(1:n, 1) into h(1:n, 1)
! (stored in work(1:n))
call stdlib${ii}$_dcopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_dlasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
11 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j+1
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_dlasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_dswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda )
end if
end do
j = j + jb
! trailing submatrix update, where
! a(j2+1, j1-1) stores l(j2+1, j1) and
! work(j2+1, 1) stores h(j2+1, 1)
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j+1, j )
a( j+1, j ) = one
call stdlib${ii}$_dcopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_dgemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), &
n,a( j3, j1-k2 ), lda,one, a( j3, j3 ), 1_${ik}$ )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block in j2-th block column with stdlib${ii}$_dgemm
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(&
j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,one, a( j3, j2 ), lda )
end do
! recover t( j+1, j )
a( j+1, j ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_dcopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 11
end if
20 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsytrf_aa
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info)
!! DSYTRF_AA: computes the factorization of a real symmetric matrix A
!! using the Aasen's algorithm. The form of the factorization is
!! A = U**T*T*U or A = L*T*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is a symmetric tridiagonal matrix.
!! 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(in) :: n, lda, lwork
integer(${ik}$), intent(out) :: info
! 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}$) :: j, lwkopt
integer(${ik}$) :: nb, mj, nj, k1, k2, j1, j2, j3, jb
real(${rk}$) :: alpha
! Intrinsic Functions
! Executable Statements
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF_AA', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
! 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<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = (nb+1)*n
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRF_AA', -info )
return
else if( lquery ) then
return
end if
! quick return
if ( n==0_${ik}$ ) then
return
endif
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( n==1_${ik}$ ) then
return
end if
! adjust block size based on the workspace size
if( lwork<((1_${ik}$+nb)*n) ) then
nb = ( lwork-n ) / n
end if
if( upper ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n))
call stdlib${ii}$_${ri}$copy( n, a( 1_${ik}$, 1_${ik}$ ), lda, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_${ri}$lasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
10 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j + 1_${ik}$
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_${ri}$lasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_${ri}$swap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ )
end if
end do
j = j + jb
! trailing submatrix update, where
! the row a(j1-1, j2-1:n) stores u(j1, j2+1:n) and
! work stores the current block of the auxiriarly matrix h
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j, j+1 )
a( j, j+1 ) = one
call stdlib${ii}$_${ri}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_${ri}$gemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), &
n,a( j1-k2, j3 ), 1_${ik}$,one, a( j3, j3 ), lda )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block of j2-th block row with stdlib${ii}$_${ri}$gemm
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-&
k2, j2 ), lda,work( j3-j1+1+k1*n ), n,one, a( j2, j3 ), lda )
end do
! recover t( j, j+1 )
a( j, j+1 ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_${ri}$copy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 10
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
! copy first column a(1:n, 1) into h(1:n, 1)
! (stored in work(1:n))
call stdlib${ii}$_${ri}$copy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_${ri}$lasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
11 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j+1
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_${ri}$lasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_${ri}$swap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda )
end if
end do
j = j + jb
! trailing submatrix update, where
! a(j2+1, j1-1) stores l(j2+1, j1) and
! work(j2+1, 1) stores h(j2+1, 1)
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j+1, j )
a( j+1, j ) = one
call stdlib${ii}$_${ri}$copy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_${ri}$gemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), &
n,a( j3, j1-k2 ), lda,one, a( j3, j3 ), 1_${ik}$ )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block in j2-th block column with stdlib${ii}$_${ri}$gemm
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(&
j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,one, a( j3, j2 ), lda )
end do
! recover t( j+1, j )
a( j+1, j ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_${ri}$copy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 11
end if
20 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sytrf_aa
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info)
!! CSYTRF_AA computes the factorization of a complex symmetric matrix A
!! using the Aasen's algorithm. The form of the factorization is
!! A = U**T*T*U or A = L*T*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is a complex symmetric tridiagonal matrix.
!! 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(in) :: n, lda, lwork
integer(${ik}$), intent(out) :: info
! 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}$) :: j, lwkopt
integer(${ik}$) :: nb, mj, nj, k1, k2, j1, j2, j3, jb
complex(sp) :: alpha
! Intrinsic Functions
! Executable Statements
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CSYTRF_AA', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
! 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<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = (nb+1)*n
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYTRF_AA', -info )
return
else if( lquery ) then
return
end if
! quick return
if ( n==0_${ik}$ ) then
return
endif
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( n==1_${ik}$ ) then
return
end if
! adjust block size based on the workspace size
if( lwork<((1_${ik}$+nb)*n) ) then
nb = ( lwork-n ) / n
end if
if( upper ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n))
call stdlib${ii}$_ccopy( n, a( 1_${ik}$, 1_${ik}$ ), lda, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_clasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
10 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j + 1_${ik}$
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_clasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_cswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ )
end if
end do
j = j + jb
! trailing submatrix update, where
! the row a(j1-1, j2-1:n) stores u(j1, j2+1:n) and
! work stores the current block of the auxiriarly matrix h
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j, j+1 )
a( j, j+1 ) = cone
call stdlib${ii}$_ccopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_cgemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),&
n,a( j1-k2, j3 ), 1_${ik}$,cone, a( j3, j3 ), lda )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block of j2-th block row with stdlib${ii}$_cgemm
call stdlib${ii}$_cgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-&
k2, j2 ), lda,work( j3-j1+1+k1*n ), n,cone, a( j2, j3 ), lda )
end do
! recover t( j, j+1 )
a( j, j+1 ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_ccopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 10
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
! copy first column a(1:n, 1) into h(1:n, 1)
! (stored in work(1:n))
call stdlib${ii}$_ccopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_clasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
11 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j+1
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_clasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_cswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda )
end if
end do
j = j + jb
! trailing submatrix update, where
! a(j2+1, j1-1) stores l(j2+1, j1) and
! work(j2+1, 1) stores h(j2+1, 1)
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j+1, j )
a( j+1, j ) = cone
call stdlib${ii}$_ccopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_cgemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),&
n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1_${ik}$ )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block in j2-th block column with stdlib${ii}$_cgemm
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, &
work( j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda )
end do
! recover t( j+1, j )
a( j+1, j ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_ccopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 11
end if
20 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_csytrf_aa
pure module subroutine stdlib${ii}$_zsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info)
!! ZSYTRF_AA computes the factorization of a complex symmetric matrix A
!! using the Aasen's algorithm. The form of the factorization is
!! A = U**T*T*U or A = L*T*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is a complex symmetric tridiagonal matrix.
!! 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(in) :: n, lda, lwork
integer(${ik}$), intent(out) :: info
! 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}$) :: j, lwkopt
integer(${ik}$) :: nb, mj, nj, k1, k2, j1, j2, j3, jb
complex(dp) :: alpha
! Intrinsic Functions
! Executable Statements
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF_AA', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
! 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<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = (nb+1)*n
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRF_AA', -info )
return
else if( lquery ) then
return
end if
! quick return
if ( n==0_${ik}$ ) then
return
endif
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( n==1_${ik}$ ) then
return
end if
! adjust block size based on the workspace size
if( lwork<((1_${ik}$+nb)*n) ) then
nb = ( lwork-n ) / n
end if
if( upper ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n))
call stdlib${ii}$_zcopy( n, a( 1_${ik}$, 1_${ik}$ ), lda, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_zlasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
10 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j + 1_${ik}$
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_zlasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_zswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ )
end if
end do
j = j + jb
! trailing submatrix update, where
! the row a(j1-1, j2-1:n) stores u(j1, j2+1:n) and
! work stores the current block of the auxiriarly matrix h
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j, j+1 )
a( j, j+1 ) = cone
call stdlib${ii}$_zcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_zgemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),&
n,a( j1-k2, j3 ), 1_${ik}$,cone, a( j3, j3 ), lda )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block of j2-th block row with stdlib${ii}$_zgemm
call stdlib${ii}$_zgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-&
k2, j2 ), lda,work( j3-j1+1+k1*n ), n,cone, a( j2, j3 ), lda )
end do
! recover t( j, j+1 )
a( j, j+1 ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_zcopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 10
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
! copy first column a(1:n, 1) into h(1:n, 1)
! (stored in work(1:n))
call stdlib${ii}$_zcopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_zlasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
11 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j+1
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_zlasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_zswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda )
end if
end do
j = j + jb
! trailing submatrix update, where
! a(j2+1, j1-1) stores l(j2+1, j1) and
! work(j2+1, 1) stores h(j2+1, 1)
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j+1, j )
a( j+1, j ) = cone
call stdlib${ii}$_zcopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_zgemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),&
n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1_${ik}$ )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block in j2-th block column with stdlib${ii}$_zgemm
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, &
work( j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda )
end do
! recover t( j+1, j )
a( j+1, j ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_zcopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 11
end if
20 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zsytrf_aa
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info)
!! ZSYTRF_AA: computes the factorization of a complex symmetric matrix A
!! using the Aasen's algorithm. The form of the factorization is
!! A = U**T*T*U or A = L*T*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is a complex symmetric tridiagonal matrix.
!! 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(in) :: n, lda, lwork
integer(${ik}$), intent(out) :: info
! 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}$) :: j, lwkopt
integer(${ik}$) :: nb, mj, nj, k1, k2, j1, j2, j3, jb
complex(${ck}$) :: alpha
! Intrinsic Functions
! Executable Statements
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF_AA', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
! 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<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = (nb+1)*n
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRF_AA', -info )
return
else if( lquery ) then
return
end if
! quick return
if ( n==0_${ik}$ ) then
return
endif
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( n==1_${ik}$ ) then
return
end if
! adjust block size based on the workspace size
if( lwork<((1_${ik}$+nb)*n) ) then
nb = ( lwork-n ) / n
end if
if( upper ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n))
call stdlib${ii}$_${ci}$copy( n, a( 1_${ik}$, 1_${ik}$ ), lda, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
10 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j + 1_${ik}$
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_${ci}$lasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_${ci}$swap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ )
end if
end do
j = j + jb
! trailing submatrix update, where
! the row a(j1-1, j2-1:n) stores u(j1, j2+1:n) and
! work stores the current block of the auxiriarly matrix h
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j, j+1 )
a( j, j+1 ) = cone
call stdlib${ii}$_${ci}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_${ci}$gemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),&
n,a( j1-k2, j3 ), 1_${ik}$,cone, a( j3, j3 ), lda )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block of j2-th block row with stdlib${ii}$_${ci}$gemm
call stdlib${ii}$_${ci}$gemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-&
k2, j2 ), lda,work( j3-j1+1+k1*n ), n,cone, a( j2, j3 ), lda )
end do
! recover t( j, j+1 )
a( j, j+1 ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 10
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
! copy first column a(1:n, 1) into h(1:n, 1)
! (stored in work(1:n))
call stdlib${ii}$_${ci}$copy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
! j is the main loop index, increasing from 1 to n in steps of
! jb, where jb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf;
! jb is either nb, or n-j+1 for the last block
j = 0_${ik}$
11 continue
if( j>=n )go to 20
! each step of the main loop
! j is the last column of the previous panel
! j1 is the first column of the current panel
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 for the first panel, and
! k1=0 for the rest
j1 = j+1
jb = min( n-j1+1, nb )
k1 = max(1_${ik}$, j)-j
! panel factorization
call stdlib${ii}$_${ci}$lasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), &
work, n, work( n*nb+1 ) )
! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot)
do j2 = j+2, min(n, j+jb+1)
ipiv( j2 ) = ipiv( j2 ) + j
if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then
call stdlib${ii}$_${ci}$swap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda )
end if
end do
j = j + jb
! trailing submatrix update, where
! a(j2+1, j1-1) stores l(j2+1, j1) and
! work(j2+1, 1) stores h(j2+1, 1)
if( j<n ) then
! if first panel and jb=1 (nb=1), then nothing to do
if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then
! merge rank-1 update with blas-3 update
alpha = a( j+1, j )
a( j+1, j ) = cone
call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
call stdlib${ii}$_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ )
! k1 identifies if the previous column of the panel has been
! explicitly stored, e.g., k1=1 and k2= 0 for the first panel,
! while k1=0 and k2=1 for the rest
if( j1>1_${ik}$ ) then
! not first panel
k2 = 1_${ik}$
else
! first panel
k2 = 0_${ik}$
! first update skips the first column
jb = jb - 1_${ik}$
end if
do j2 = j+1, n, nb
nj = min( nb, n-j2+1 )
! update (j2, j2) diagonal block with stdlib${ii}$_${ci}$gemv
j3 = j2
do mj = nj-1, 1, -1
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),&
n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1_${ik}$ )
j3 = j3 + 1_${ik}$
end do
! update off-diagonal block in j2-th block column with stdlib${ii}$_${ci}$gemm
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, &
work( j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda )
end do
! recover t( j+1, j )
a( j+1, j ) = alpha
end if
! work(j+1, 1) stores h(j+1, 1)
call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
go to 11
end if
20 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$sytrf_aa
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work )
!! DLATRF_AA factorizes a panel of a real symmetric matrix A using
!! the Aasen's algorithm. The panel consists of a set of NB rows of A
!! when UPLO is U, or a set of NB columns when UPLO is L.
!! In order to factorize the panel, the Aasen's algorithm requires the
!! last row, or column, of the previous panel. The first row, or column,
!! of A is set to be the first row, or column, of an identity matrix,
!! which is used to factorize the first panel.
!! The resulting J-th row of U, or J-th column of L, is stored in the
!! (J-1)-th row, or column, of A (without the unit diagonals), while
!! the diagonal and subdiagonal of A are overwritten by those of T.
! -- 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(in) :: m, nb, j1, lda, ldh
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*), h(ldh,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, k, k1, i1, i2, mj
real(sp) :: piv, alpha
! Intrinsic Functions
! Executable Statements
j = 1_${ik}$
! k1 is the first column of the panel to be factorized
! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks
k1 = (2_${ik}$-j1)+1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
10 continue
if ( j>min(m, nb) )go to 20
! k is the column to be factorized
! when being called from stdlib${ii}$_ssytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j),
! where h(j:m, j) has been initialized to be a(j, j:m)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,&
one, h( j, j ), 1_${ik}$ )
end if
! copy h(i:m, i) into work
call stdlib${ii}$_scopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j-1, j:m) * t(j-1,j),
! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m)
alpha = -a( k-1, j )
call stdlib${ii}$_saxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( k, j ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l(j, (j+1):m)
! where a(j, j) stores t(j, j) and a(j-1, (j+1):m) stores u(j, (j+1):m)
if( k>1_${ik}$ ) then
alpha = -a( k, j )
call stdlib${ii}$_saxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_isamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1, i1+1:m) with a(i1+1:m, i2)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_sswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ )
! swap a(i1, i2+1:m) with a(i2, i2+1:m)
if( i2<m )call stdlib${ii}$_sswap( m-i2, a( j1+i1-1, i2+1 ), lda,a( j1+i2-1, i2+1 ),&
lda )
! swap a(i1, i1) with a(i2,i2)
piv = a( i1+j1-1, i1 )
a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
a( j1+i2-1, i2 ) = piv
! swap h(i1, 1:j1) with h(i2, 1:j1)
call stdlib${ii}$_sswap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_sswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j, j+1) = t(j, j+1)
a( k, j+1 ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j:m, j),
call stdlib${ii}$_scopy( m-j, a( k+1, j+1 ), lda,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( k, j+1 )/=zero ) then
alpha = one / a( k, j+1 )
call stdlib${ii}$_scopy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( k, j+2 ), lda )
call stdlib${ii}$_sscal( m-j-1, alpha, a( k, j+2 ), lda )
else
call stdlib${ii}$_slaset( 'FULL', 1_${ik}$, m-j-1, zero, zero,a( k, j+2 ), lda)
end if
end if
end if
j = j + 1_${ik}$
go to 10
20 continue
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
30 continue
if( j>min( m, nb ) )go to 40
! k is the column to be factorized
! when being called from stdlib${ii}$_ssytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t,
! where h(j:m, j) has been initialized to be a(j:m, j)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1_${ik}$ ), lda,&
one, h( j, j ), 1_${ik}$ )
end if
! copy h(j:m, j) into work
call stdlib${ii}$_scopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j:m, j-1) * t(j-1,j),
! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1)
alpha = -a( j, k-1 )
call stdlib${ii}$_saxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( j, k ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l((j+1):m, j)
! where a(j, j) = t(j, j) and a((j+1):m, j-1) = l((j+1):m, j)
if( k>1_${ik}$ ) then
alpha = -a( j, k )
call stdlib${ii}$_saxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_isamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1+1:m, i1) with a(i2, i1+1:m)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_sswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda )
! swap a(i2+1:m, i1) with a(i2+1:m, i2)
if( i2<m )call stdlib${ii}$_sswap( m-i2, a( i2+1, j1+i1-1 ), 1_${ik}$,a( i2+1, j1+i2-1 ), &
1_${ik}$ )
! swap a(i1, i1) with a(i2, i2)
piv = a( i1, j1+i1-1 )
a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
a( i2, j1+i2-1 ) = piv
! swap h(i1, i1:j1) with h(i2, i2:j1)
call stdlib${ii}$_sswap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_sswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j+1, j) = t(j+1, j)
a( j+1, k ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j+1:m, j),
call stdlib${ii}$_scopy( m-j, a( j+1, k+1 ), 1_${ik}$,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( j+1, k )/=zero ) then
alpha = one / a( j+1, k )
call stdlib${ii}$_scopy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( j+2, k ), 1_${ik}$ )
call stdlib${ii}$_sscal( m-j-1, alpha, a( j+2, k ), 1_${ik}$ )
else
call stdlib${ii}$_slaset( 'FULL', m-j-1, 1_${ik}$, zero, zero,a( j+2, k ), lda )
end if
end if
end if
j = j + 1_${ik}$
go to 30
40 continue
end if
return
end subroutine stdlib${ii}$_slasyf_aa
pure module subroutine stdlib${ii}$_dlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work )
!! DLATRF_AA factorizes a panel of a real symmetric matrix A using
!! the Aasen's algorithm. The panel consists of a set of NB rows of A
!! when UPLO is U, or a set of NB columns when UPLO is L.
!! In order to factorize the panel, the Aasen's algorithm requires the
!! last row, or column, of the previous panel. The first row, or column,
!! of A is set to be the first row, or column, of an identity matrix,
!! which is used to factorize the first panel.
!! The resulting J-th row of U, or J-th column of L, is stored in the
!! (J-1)-th row, or column, of A (without the unit diagonals), while
!! the diagonal and subdiagonal of A are overwritten by those of T.
! -- 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(in) :: m, nb, j1, lda, ldh
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*), h(ldh,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, k, k1, i1, i2, mj
real(dp) :: piv, alpha
! Intrinsic Functions
! Executable Statements
j = 1_${ik}$
! k1 is the first column of the panel to be factorized
! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks
k1 = (2_${ik}$-j1)+1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
10 continue
if ( j>min(m, nb) )go to 20
! k is the column to be factorized
! when being called from stdlib${ii}$_dsytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j),
! where h(j:m, j) has been initialized to be a(j, j:m)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,&
one, h( j, j ), 1_${ik}$ )
end if
! copy h(i:m, i) into work
call stdlib${ii}$_dcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j-1, j:m) * t(j-1,j),
! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m)
alpha = -a( k-1, j )
call stdlib${ii}$_daxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( k, j ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l(j, (j+1):m)
! where a(j, j) stores t(j, j) and a(j-1, (j+1):m) stores u(j, (j+1):m)
if( k>1_${ik}$ ) then
alpha = -a( k, j )
call stdlib${ii}$_daxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_idamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1, i1+1:m) with a(i1+1:m, i2)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_dswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ )
! swap a(i1, i2+1:m) with a(i2, i2+1:m)
if( i2<m )call stdlib${ii}$_dswap( m-i2, a( j1+i1-1, i2+1 ), lda,a( j1+i2-1, i2+1 ),&
lda )
! swap a(i1, i1) with a(i2,i2)
piv = a( i1+j1-1, i1 )
a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
a( j1+i2-1, i2 ) = piv
! swap h(i1, 1:j1) with h(i2, 1:j1)
call stdlib${ii}$_dswap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_dswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j, j+1) = t(j, j+1)
a( k, j+1 ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j:m, j),
call stdlib${ii}$_dcopy( m-j, a( k+1, j+1 ), lda,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( k, j+1 )/=zero ) then
alpha = one / a( k, j+1 )
call stdlib${ii}$_dcopy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( k, j+2 ), lda )
call stdlib${ii}$_dscal( m-j-1, alpha, a( k, j+2 ), lda )
else
call stdlib${ii}$_dlaset( 'FULL', 1_${ik}$, m-j-1, zero, zero,a( k, j+2 ), lda)
end if
end if
end if
j = j + 1_${ik}$
go to 10
20 continue
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
30 continue
if( j>min( m, nb ) )go to 40
! k is the column to be factorized
! when being called from stdlib${ii}$_dsytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t,
! where h(j:m, j) has been initialized to be a(j:m, j)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1_${ik}$ ), lda,&
one, h( j, j ), 1_${ik}$ )
end if
! copy h(j:m, j) into work
call stdlib${ii}$_dcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j:m, j-1) * t(j-1,j),
! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1)
alpha = -a( j, k-1 )
call stdlib${ii}$_daxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( j, k ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l((j+1):m, j)
! where a(j, j) = t(j, j) and a((j+1):m, j-1) = l((j+1):m, j)
if( k>1_${ik}$ ) then
alpha = -a( j, k )
call stdlib${ii}$_daxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_idamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1+1:m, i1) with a(i2, i1+1:m)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_dswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda )
! swap a(i2+1:m, i1) with a(i2+1:m, i2)
if( i2<m )call stdlib${ii}$_dswap( m-i2, a( i2+1, j1+i1-1 ), 1_${ik}$,a( i2+1, j1+i2-1 ), &
1_${ik}$ )
! swap a(i1, i1) with a(i2, i2)
piv = a( i1, j1+i1-1 )
a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
a( i2, j1+i2-1 ) = piv
! swap h(i1, i1:j1) with h(i2, i2:j1)
call stdlib${ii}$_dswap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_dswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j+1, j) = t(j+1, j)
a( j+1, k ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j+1:m, j),
call stdlib${ii}$_dcopy( m-j, a( j+1, k+1 ), 1_${ik}$,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( j+1, k )/=zero ) then
alpha = one / a( j+1, k )
call stdlib${ii}$_dcopy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( j+2, k ), 1_${ik}$ )
call stdlib${ii}$_dscal( m-j-1, alpha, a( j+2, k ), 1_${ik}$ )
else
call stdlib${ii}$_dlaset( 'FULL', m-j-1, 1_${ik}$, zero, zero,a( j+2, k ), lda )
end if
end if
end if
j = j + 1_${ik}$
go to 30
40 continue
end if
return
end subroutine stdlib${ii}$_dlasyf_aa
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work )
!! DLATRF_AA factorizes a panel of a real symmetric matrix A using
!! the Aasen's algorithm. The panel consists of a set of NB rows of A
!! when UPLO is U, or a set of NB columns when UPLO is L.
!! In order to factorize the panel, the Aasen's algorithm requires the
!! last row, or column, of the previous panel. The first row, or column,
!! of A is set to be the first row, or column, of an identity matrix,
!! which is used to factorize the first panel.
!! The resulting J-th row of U, or J-th column of L, is stored in the
!! (J-1)-th row, or column, of A (without the unit diagonals), while
!! the diagonal and subdiagonal of A are overwritten by those of T.
! -- 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(in) :: m, nb, j1, lda, ldh
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*), h(ldh,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, k, k1, i1, i2, mj
real(${rk}$) :: piv, alpha
! Intrinsic Functions
! Executable Statements
j = 1_${ik}$
! k1 is the first column of the panel to be factorized
! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks
k1 = (2_${ik}$-j1)+1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
10 continue
if ( j>min(m, nb) )go to 20
! k is the column to be factorized
! when being called from stdlib${ii}$_${ri}$sytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j),
! where h(j:m, j) has been initialized to be a(j, j:m)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,&
one, h( j, j ), 1_${ik}$ )
end if
! copy h(i:m, i) into work
call stdlib${ii}$_${ri}$copy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j-1, j:m) * t(j-1,j),
! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m)
alpha = -a( k-1, j )
call stdlib${ii}$_${ri}$axpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( k, j ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l(j, (j+1):m)
! where a(j, j) stores t(j, j) and a(j-1, (j+1):m) stores u(j, (j+1):m)
if( k>1_${ik}$ ) then
alpha = -a( k, j )
call stdlib${ii}$_${ri}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_i${ri}$amax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1, i1+1:m) with a(i1+1:m, i2)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_${ri}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ )
! swap a(i1, i2+1:m) with a(i2, i2+1:m)
if( i2<m )call stdlib${ii}$_${ri}$swap( m-i2, a( j1+i1-1, i2+1 ), lda,a( j1+i2-1, i2+1 ),&
lda )
! swap a(i1, i1) with a(i2,i2)
piv = a( i1+j1-1, i1 )
a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
a( j1+i2-1, i2 ) = piv
! swap h(i1, 1:j1) with h(i2, 1:j1)
call stdlib${ii}$_${ri}$swap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_${ri}$swap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j, j+1) = t(j, j+1)
a( k, j+1 ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j:m, j),
call stdlib${ii}$_${ri}$copy( m-j, a( k+1, j+1 ), lda,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( k, j+1 )/=zero ) then
alpha = one / a( k, j+1 )
call stdlib${ii}$_${ri}$copy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( k, j+2 ), lda )
call stdlib${ii}$_${ri}$scal( m-j-1, alpha, a( k, j+2 ), lda )
else
call stdlib${ii}$_${ri}$laset( 'FULL', 1_${ik}$, m-j-1, zero, zero,a( k, j+2 ), lda)
end if
end if
end if
j = j + 1_${ik}$
go to 10
20 continue
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
30 continue
if( j>min( m, nb ) )go to 40
! k is the column to be factorized
! when being called from stdlib${ii}$_${ri}$sytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t,
! where h(j:m, j) has been initialized to be a(j:m, j)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1_${ik}$ ), lda,&
one, h( j, j ), 1_${ik}$ )
end if
! copy h(j:m, j) into work
call stdlib${ii}$_${ri}$copy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j:m, j-1) * t(j-1,j),
! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1)
alpha = -a( j, k-1 )
call stdlib${ii}$_${ri}$axpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( j, k ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l((j+1):m, j)
! where a(j, j) = t(j, j) and a((j+1):m, j-1) = l((j+1):m, j)
if( k>1_${ik}$ ) then
alpha = -a( j, k )
call stdlib${ii}$_${ri}$axpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_i${ri}$amax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1+1:m, i1) with a(i2, i1+1:m)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_${ri}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda )
! swap a(i2+1:m, i1) with a(i2+1:m, i2)
if( i2<m )call stdlib${ii}$_${ri}$swap( m-i2, a( i2+1, j1+i1-1 ), 1_${ik}$,a( i2+1, j1+i2-1 ), &
1_${ik}$ )
! swap a(i1, i1) with a(i2, i2)
piv = a( i1, j1+i1-1 )
a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
a( i2, j1+i2-1 ) = piv
! swap h(i1, i1:j1) with h(i2, i2:j1)
call stdlib${ii}$_${ri}$swap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_${ri}$swap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j+1, j) = t(j+1, j)
a( j+1, k ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j+1:m, j),
call stdlib${ii}$_${ri}$copy( m-j, a( j+1, k+1 ), 1_${ik}$,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( j+1, k )/=zero ) then
alpha = one / a( j+1, k )
call stdlib${ii}$_${ri}$copy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( j+2, k ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( m-j-1, alpha, a( j+2, k ), 1_${ik}$ )
else
call stdlib${ii}$_${ri}$laset( 'FULL', m-j-1, 1_${ik}$, zero, zero,a( j+2, k ), lda )
end if
end if
end if
j = j + 1_${ik}$
go to 30
40 continue
end if
return
end subroutine stdlib${ii}$_${ri}$lasyf_aa
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work )
!! DLATRF_AA factorizes a panel of a complex symmetric matrix A using
!! the Aasen's algorithm. The panel consists of a set of NB rows of A
!! when UPLO is U, or a set of NB columns when UPLO is L.
!! In order to factorize the panel, the Aasen's algorithm requires the
!! last row, or column, of the previous panel. The first row, or column,
!! of A is set to be the first row, or column, of an identity matrix,
!! which is used to factorize the first panel.
!! The resulting J-th row of U, or J-th column of L, is stored in the
!! (J-1)-th row, or column, of A (without the unit diagonals), while
!! the diagonal and subdiagonal of A are overwritten by those of T.
! -- 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(in) :: m, nb, j1, lda, ldh
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), h(ldh,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, k, k1, i1, i2, mj
complex(sp) :: piv, alpha
! Intrinsic Functions
! Executable Statements
j = 1_${ik}$
! k1 is the first column of the panel to be factorized
! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks
k1 = (2_${ik}$-j1)+1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
10 continue
if ( j>min(m, nb) )go to 20
! k is the column to be factorized
! when being called from stdlib${ii}$_csytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j),
! where h(j:m, j) has been initialized to be a(j, j:m)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,&
cone, h( j, j ), 1_${ik}$ )
end if
! copy h(i:m, i) into work
call stdlib${ii}$_ccopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j-1, j:m) * t(j-1,j),
! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m)
alpha = -a( k-1, j )
call stdlib${ii}$_caxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( k, j ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l(j, (j+1):m)
! where a(j, j) stores t(j, j) and a(j-1, (j+1):m) stores u(j, (j+1):m)
if( k>1_${ik}$ ) then
alpha = -a( k, j )
call stdlib${ii}$_caxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_icamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1, i1+1:m) with a(i1+1:m, i2)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_cswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ )
! swap a(i1, i2+1:m) with a(i2, i2+1:m)
if( i2<m )call stdlib${ii}$_cswap( m-i2, a( j1+i1-1, i2+1 ), lda,a( j1+i2-1, i2+1 ),&
lda )
! swap a(i1, i1) with a(i2,i2)
piv = a( i1+j1-1, i1 )
a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
a( j1+i2-1, i2 ) = piv
! swap h(i1, 1:j1) with h(i2, 1:j1)
call stdlib${ii}$_cswap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_cswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j, j+1) = t(j, j+1)
a( k, j+1 ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j:m, j),
call stdlib${ii}$_ccopy( m-j, a( k+1, j+1 ), lda,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( k, j+1 )/=czero ) then
alpha = cone / a( k, j+1 )
call stdlib${ii}$_ccopy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( k, j+2 ), lda )
call stdlib${ii}$_cscal( m-j-1, alpha, a( k, j+2 ), lda )
else
call stdlib${ii}$_claset( 'FULL', 1_${ik}$, m-j-1, czero, czero,a( k, j+2 ), lda)
end if
end if
end if
j = j + 1_${ik}$
go to 10
20 continue
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
30 continue
if( j>min( m, nb ) )go to 40
! k is the column to be factorized
! when being called from stdlib${ii}$_csytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t,
! where h(j:m, j) has been initialized to be a(j:m, j)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), &
lda,cone, h( j, j ), 1_${ik}$ )
end if
! copy h(j:m, j) into work
call stdlib${ii}$_ccopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j:m, j-1) * t(j-1,j),
! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1)
alpha = -a( j, k-1 )
call stdlib${ii}$_caxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( j, k ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l((j+1):m, j)
! where a(j, j) = t(j, j) and a((j+1):m, j-1) = l((j+1):m, j)
if( k>1_${ik}$ ) then
alpha = -a( j, k )
call stdlib${ii}$_caxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_icamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1+1:m, i1) with a(i2, i1+1:m)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_cswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda )
! swap a(i2+1:m, i1) with a(i2+1:m, i2)
if( i2<m )call stdlib${ii}$_cswap( m-i2, a( i2+1, j1+i1-1 ), 1_${ik}$,a( i2+1, j1+i2-1 ), &
1_${ik}$ )
! swap a(i1, i1) with a(i2, i2)
piv = a( i1, j1+i1-1 )
a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
a( i2, j1+i2-1 ) = piv
! swap h(i1, i1:j1) with h(i2, i2:j1)
call stdlib${ii}$_cswap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_cswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j+1, j) = t(j+1, j)
a( j+1, k ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j+1:m, j),
call stdlib${ii}$_ccopy( m-j, a( j+1, k+1 ), 1_${ik}$,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( j+1, k )/=czero ) then
alpha = cone / a( j+1, k )
call stdlib${ii}$_ccopy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( j+2, k ), 1_${ik}$ )
call stdlib${ii}$_cscal( m-j-1, alpha, a( j+2, k ), 1_${ik}$ )
else
call stdlib${ii}$_claset( 'FULL', m-j-1, 1_${ik}$, czero, czero,a( j+2, k ), lda )
end if
end if
end if
j = j + 1_${ik}$
go to 30
40 continue
end if
return
end subroutine stdlib${ii}$_clasyf_aa
pure module subroutine stdlib${ii}$_zlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work )
!! DLATRF_AA factorizes a panel of a complex symmetric matrix A using
!! the Aasen's algorithm. The panel consists of a set of NB rows of A
!! when UPLO is U, or a set of NB columns when UPLO is L.
!! In order to factorize the panel, the Aasen's algorithm requires the
!! last row, or column, of the previous panel. The first row, or column,
!! of A is set to be the first row, or column, of an identity matrix,
!! which is used to factorize the first panel.
!! The resulting J-th row of U, or J-th column of L, is stored in the
!! (J-1)-th row, or column, of A (without the unit diagonals), while
!! the diagonal and subdiagonal of A are overwritten by those of T.
! -- 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(in) :: m, nb, j1, lda, ldh
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), h(ldh,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, k, k1, i1, i2, mj
complex(dp) :: piv, alpha
! Intrinsic Functions
! Executable Statements
j = 1_${ik}$
! k1 is the first column of the panel to be factorized
! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks
k1 = (2_${ik}$-j1)+1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
10 continue
if ( j>min(m, nb) )go to 20
! k is the column to be factorized
! when being called from stdlib${ii}$_zsytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j),
! where h(j:m, j) has been initialized to be a(j, j:m)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,&
cone, h( j, j ), 1_${ik}$ )
end if
! copy h(i:m, i) into work
call stdlib${ii}$_zcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j-1, j:m) * t(j-1,j),
! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m)
alpha = -a( k-1, j )
call stdlib${ii}$_zaxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( k, j ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l(j, (j+1):m)
! where a(j, j) stores t(j, j) and a(j-1, (j+1):m) stores u(j, (j+1):m)
if( k>1_${ik}$ ) then
alpha = -a( k, j )
call stdlib${ii}$_zaxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_izamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1, i1+1:m) with a(i1+1:m, i2)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_zswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ )
! swap a(i1, i2+1:m) with a(i2, i2+1:m)
if( i2<m )call stdlib${ii}$_zswap( m-i2, a( j1+i1-1, i2+1 ), lda,a( j1+i2-1, i2+1 ),&
lda )
! swap a(i1, i1) with a(i2,i2)
piv = a( i1+j1-1, i1 )
a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
a( j1+i2-1, i2 ) = piv
! swap h(i1, 1:j1) with h(i2, 1:j1)
call stdlib${ii}$_zswap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_zswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j, j+1) = t(j, j+1)
a( k, j+1 ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j:m, j),
call stdlib${ii}$_zcopy( m-j, a( k+1, j+1 ), lda,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( k, j+1 )/=czero ) then
alpha = cone / a( k, j+1 )
call stdlib${ii}$_zcopy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( k, j+2 ), lda )
call stdlib${ii}$_zscal( m-j-1, alpha, a( k, j+2 ), lda )
else
call stdlib${ii}$_zlaset( 'FULL', 1_${ik}$, m-j-1, czero, czero,a( k, j+2 ), lda)
end if
end if
end if
j = j + 1_${ik}$
go to 10
20 continue
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
30 continue
if( j>min( m, nb ) )go to 40
! k is the column to be factorized
! when being called from stdlib${ii}$_zsytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t,
! where h(j:m, j) has been initialized to be a(j:m, j)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), &
lda,cone, h( j, j ), 1_${ik}$ )
end if
! copy h(j:m, j) into work
call stdlib${ii}$_zcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j:m, j-1) * t(j-1,j),
! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1)
alpha = -a( j, k-1 )
call stdlib${ii}$_zaxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( j, k ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l((j+1):m, j)
! where a(j, j) = t(j, j) and a((j+1):m, j-1) = l((j+1):m, j)
if( k>1_${ik}$ ) then
alpha = -a( j, k )
call stdlib${ii}$_zaxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_izamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1+1:m, i1) with a(i2, i1+1:m)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_zswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda )
! swap a(i2+1:m, i1) with a(i2+1:m, i2)
if( i2<m )call stdlib${ii}$_zswap( m-i2, a( i2+1, j1+i1-1 ), 1_${ik}$,a( i2+1, j1+i2-1 ), &
1_${ik}$ )
! swap a(i1, i1) with a(i2, i2)
piv = a( i1, j1+i1-1 )
a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
a( i2, j1+i2-1 ) = piv
! swap h(i1, i1:j1) with h(i2, i2:j1)
call stdlib${ii}$_zswap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_zswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j+1, j) = t(j+1, j)
a( j+1, k ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j+1:m, j),
call stdlib${ii}$_zcopy( m-j, a( j+1, k+1 ), 1_${ik}$,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( j+1, k )/=czero ) then
alpha = cone / a( j+1, k )
call stdlib${ii}$_zcopy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( j+2, k ), 1_${ik}$ )
call stdlib${ii}$_zscal( m-j-1, alpha, a( j+2, k ), 1_${ik}$ )
else
call stdlib${ii}$_zlaset( 'FULL', m-j-1, 1_${ik}$, czero, czero,a( j+2, k ), lda )
end if
end if
end if
j = j + 1_${ik}$
go to 30
40 continue
end if
return
end subroutine stdlib${ii}$_zlasyf_aa
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work )
!! DLATRF_AA factorizes a panel of a complex symmetric matrix A using
!! the Aasen's algorithm. The panel consists of a set of NB rows of A
!! when UPLO is U, or a set of NB columns when UPLO is L.
!! In order to factorize the panel, the Aasen's algorithm requires the
!! last row, or column, of the previous panel. The first row, or column,
!! of A is set to be the first row, or column, of an identity matrix,
!! which is used to factorize the first panel.
!! The resulting J-th row of U, or J-th column of L, is stored in the
!! (J-1)-th row, or column, of A (without the unit diagonals), while
!! the diagonal and subdiagonal of A are overwritten by those of T.
! -- 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(in) :: m, nb, j1, lda, ldh
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), h(ldh,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, k, k1, i1, i2, mj
complex(${ck}$) :: piv, alpha
! Intrinsic Functions
! Executable Statements
j = 1_${ik}$
! k1 is the first column of the panel to be factorized
! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks
k1 = (2_${ik}$-j1)+1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
! .....................................................
! factorize a as u**t*d*u using the upper triangle of a
! .....................................................
10 continue
if ( j>min(m, nb) )go to 20
! k is the column to be factorized
! when being called from stdlib${ii}$_${ci}$sytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j),
! where h(j:m, j) has been initialized to be a(j, j:m)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,&
cone, h( j, j ), 1_${ik}$ )
end if
! copy h(i:m, i) into work
call stdlib${ii}$_${ci}$copy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j-1, j:m) * t(j-1,j),
! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m)
alpha = -a( k-1, j )
call stdlib${ii}$_${ci}$axpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( k, j ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l(j, (j+1):m)
! where a(j, j) stores t(j, j) and a(j-1, (j+1):m) stores u(j, (j+1):m)
if( k>1_${ik}$ ) then
alpha = -a( k, j )
call stdlib${ii}$_${ci}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_i${ci}$amax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1, i1+1:m) with a(i1+1:m, i2)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_${ci}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ )
! swap a(i1, i2+1:m) with a(i2, i2+1:m)
if( i2<m )call stdlib${ii}$_${ci}$swap( m-i2, a( j1+i1-1, i2+1 ), lda,a( j1+i2-1, i2+1 ),&
lda )
! swap a(i1, i1) with a(i2,i2)
piv = a( i1+j1-1, i1 )
a( j1+i1-1, i1 ) = a( j1+i2-1, i2 )
a( j1+i2-1, i2 ) = piv
! swap h(i1, 1:j1) with h(i2, 1:j1)
call stdlib${ii}$_${ci}$swap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_${ci}$swap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j, j+1) = t(j, j+1)
a( k, j+1 ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j:m, j),
call stdlib${ii}$_${ci}$copy( m-j, a( k+1, j+1 ), lda,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( k, j+1 )/=czero ) then
alpha = cone / a( k, j+1 )
call stdlib${ii}$_${ci}$copy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( k, j+2 ), lda )
call stdlib${ii}$_${ci}$scal( m-j-1, alpha, a( k, j+2 ), lda )
else
call stdlib${ii}$_${ci}$laset( 'FULL', 1_${ik}$, m-j-1, czero, czero,a( k, j+2 ), lda)
end if
end if
end if
j = j + 1_${ik}$
go to 10
20 continue
else
! .....................................................
! factorize a as l*d*l**t using the lower triangle of a
! .....................................................
30 continue
if( j>min( m, nb ) )go to 40
! k is the column to be factorized
! when being called from stdlib${ii}$_${ci}$sytrf_aa,
! > for the first block column, j1 is 1, hence j1+j-1 is j,
! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1,
k = j1+j-1
if( j==m ) then
! only need to compute t(j, j)
mj = 1_${ik}$
else
mj = m-j+1
end if
! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t,
! where h(j:m, j) has been initialized to be a(j:m, j)
if( k>2_${ik}$ ) then
! k is the column to be factorized
! > for the first block column, k is j, skipping the first two
! columns
! > for the rest of the columns, k is j+1, skipping only the
! first column
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), &
lda,cone, h( j, j ), 1_${ik}$ )
end if
! copy h(j:m, j) into work
call stdlib${ii}$_${ci}$copy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( j>k1 ) then
! compute work := work - l(j:m, j-1) * t(j-1,j),
! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1)
alpha = -a( j, k-1 )
call stdlib${ii}$_${ci}$axpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
end if
! set a(j, j) = t(j, j)
a( j, k ) = work( 1_${ik}$ )
if( j<m ) then
! compute work(2:m) = t(j, j) l((j+1):m, j)
! where a(j, j) = t(j, j) and a((j+1):m, j-1) = l((j+1):m, j)
if( k>1_${ik}$ ) then
alpha = -a( j, k )
call stdlib${ii}$_${ci}$axpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ )
endif
! find max(|work(2:m)|)
i2 = stdlib${ii}$_i${ci}$amax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$
piv = work( i2 )
! apply symmetric pivot
if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then
! swap work(i1) and work(i2)
i1 = 2_${ik}$
work( i2 ) = work( i1 )
work( i1 ) = piv
! swap a(i1+1:m, i1) with a(i2, i1+1:m)
i1 = i1+j-1
i2 = i2+j-1
call stdlib${ii}$_${ci}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda )
! swap a(i2+1:m, i1) with a(i2+1:m, i2)
if( i2<m )call stdlib${ii}$_${ci}$swap( m-i2, a( i2+1, j1+i1-1 ), 1_${ik}$,a( i2+1, j1+i2-1 ), &
1_${ik}$ )
! swap a(i1, i1) with a(i2, i2)
piv = a( i1, j1+i1-1 )
a( i1, j1+i1-1 ) = a( i2, j1+i2-1 )
a( i2, j1+i2-1 ) = piv
! swap h(i1, i1:j1) with h(i2, i2:j1)
call stdlib${ii}$_${ci}$swap( i1-1, h( i1, 1_${ik}$ ), ldh, h( i2, 1_${ik}$ ), ldh )
ipiv( i1 ) = i2
if( i1>(k1-1) ) then
! swap l(1:i1-1, i1) with l(1:i1-1, i2),
! skipping the first column
call stdlib${ii}$_${ci}$swap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda )
end if
else
ipiv( j+1 ) = j+1
endif
! set a(j+1, j) = t(j+1, j)
a( j+1, k ) = work( 2_${ik}$ )
if( j<nb ) then
! copy a(j+1:m, j+1) into h(j+1:m, j),
call stdlib${ii}$_${ci}$copy( m-j, a( j+1, k+1 ), 1_${ik}$,h( j+1, j+1 ), 1_${ik}$ )
end if
! compute l(j+2, j+1) = work( 3:m ) / t(j, j+1),
! where a(j, j+1) = t(j, j+1) and a(j+2:m, j) = l(j+2:m, j+1)
if( j<(m-1) ) then
if( a( j+1, k )/=czero ) then
alpha = cone / a( j+1, k )
call stdlib${ii}$_${ci}$copy( m-j-1, work( 3_${ik}$ ), 1_${ik}$, a( j+2, k ), 1_${ik}$ )
call stdlib${ii}$_${ci}$scal( m-j-1, alpha, a( j+2, k ), 1_${ik}$ )
else
call stdlib${ii}$_${ci}$laset( 'FULL', m-j-1, 1_${ik}$, czero, czero,a( j+2, k ), lda )
end if
end if
end if
j = j + 1_${ik}$
go to 30
40 continue
end if
return
end subroutine stdlib${ii}$_${ci}$lasyf_aa
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info )
!! SSYTRS_AA solves a system of linear equations A*X = B with a real
!! symmetric matrix A using the factorization A = U**T*T*U or
!! A = L*T*L**T computed by SSYTRF_AA.
! -- 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(in) :: n, nrhs, lda, ldb, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: b(ldb,*)
real(sp), intent(out) :: work(*)
! =====================================================================
logical(lk) :: lquery, upper
integer(${ik}$) :: k, kp, lwkopt
! Intrinsic Functions
! Executable Statements
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( 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}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n-2 ) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRS_AA', -info )
return
else if( lquery ) then
lwkopt = (3_${ik}$*n-2)
work( 1_${ik}$ ) = lwkopt
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u**t*t*u.
! 1) forward substitution with u**t
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
k = 1_${ik}$
do while ( k<=n )
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}$
end do
! compute u**t \ b -> b [ (u**t \p**t * b) ]
call stdlib${ii}$_strsm( 'L', 'U', 'T', 'U', n-1, nrhs, one, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (u**t \p**t * b) ]
call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n-1, a(1_${ik}$, 2_${ik}$), lda+1, work(1_${ik}$), 1_${ik}$)
call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n-1, a(1_${ik}$, 2_${ik}$), lda+1, work(2_${ik}$*n), 1_${ik}$)
end if
call stdlib${ii}$_sgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info)
! 3) backward substitution with u
if( n>1_${ik}$ ) then
! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ]
call stdlib${ii}$_strsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1_${ik}$, 2_${ik}$ ),lda, b(2_${ik}$, 1_${ik}$), &
ldb)
! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ]
k = n
do while ( k>=1 )
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}$
end do
end if
else
! solve a*x = b, where a = l*t*l**t.
! 1) forward substitution with l
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
k = 1_${ik}$
do while ( k<=n )
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}$
end do
! compute l \ b -> b [ (l \p**t * b) ]
call stdlib${ii}$_strsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2_${ik}$, 1_${ik}$),lda, b(2_${ik}$, 1_${ik}$), &
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (l \p**t * b) ]
call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n-1, a(2_${ik}$, 1_${ik}$), lda+1, work(1_${ik}$), 1_${ik}$)
call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n-1, a(2_${ik}$, 1_${ik}$), lda+1, work(2_${ik}$*n), 1_${ik}$)
end if
call stdlib${ii}$_sgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info)
! 3) backward substitution with l**t
if( n>1_${ik}$ ) then
! compute l**t \ b -> b [ l**t \ (t \ (l \p**t * b) ) ]
call stdlib${ii}$_strsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ]
k = n
do while ( k>=1 )
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}$
end do
end if
end if
return
end subroutine stdlib${ii}$_ssytrs_aa
pure module subroutine stdlib${ii}$_dsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info )
!! DSYTRS_AA solves a system of linear equations A*X = B with a real
!! symmetric matrix A using the factorization A = U**T*T*U or
!! A = L*T*L**T computed by DSYTRF_AA.
! -- 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(in) :: n, nrhs, lda, ldb, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: b(ldb,*)
real(dp), intent(out) :: work(*)
! =====================================================================
logical(lk) :: lquery, upper
integer(${ik}$) :: k, kp, lwkopt
! Intrinsic Functions
! Executable Statements
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( 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}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n-2 ) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRS_AA', -info )
return
else if( lquery ) then
lwkopt = (3_${ik}$*n-2)
work( 1_${ik}$ ) = lwkopt
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u**t*t*u.
! 1) forward substitution with u**t
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute u**t \ b -> b [ (u**t \p**t * b) ]
call stdlib${ii}$_dtrsm('L', 'U', 'T', 'U', n-1, nrhs, one, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (u**t \p**t * b) ]
call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_dgtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info )
! 3) backward substitution with u
if( n>1_${ik}$ ) then
! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ]
call stdlib${ii}$_dtrsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
else
! solve a*x = b, where a = l*t*l**t.
! 1) forward substitution with l
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute l \ b -> b [ (l \p**t * b) ]
call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (l \p**t * b) ]
call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_dgtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info)
! 3) backward substitution with l**t
if( n>1_${ik}$ ) then
! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ]
call stdlib${ii}$_dtrsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_dsytrs_aa
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info )
!! DSYTRS_AA: solves a system of linear equations A*X = B with a real
!! symmetric matrix A using the factorization A = U**T*T*U or
!! A = L*T*L**T computed by DSYTRF_AA.
! -- 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(in) :: n, nrhs, lda, ldb, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(inout) :: b(ldb,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
logical(lk) :: lquery, upper
integer(${ik}$) :: k, kp, lwkopt
! Intrinsic Functions
! Executable Statements
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( 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}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n-2 ) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRS_AA', -info )
return
else if( lquery ) then
lwkopt = (3_${ik}$*n-2)
work( 1_${ik}$ ) = lwkopt
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u**t*t*u.
! 1) forward substitution with u**t
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute u**t \ b -> b [ (u**t \p**t * b) ]
call stdlib${ii}$_${ri}$trsm('L', 'U', 'T', 'U', n-1, nrhs, one, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (u**t \p**t * b) ]
call stdlib${ii}$_${ri}$lacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_${ri}$lacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_${ri}$gtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info )
! 3) backward substitution with u
if( n>1_${ik}$ ) then
! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ]
call stdlib${ii}$_${ri}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
else
! solve a*x = b, where a = l*t*l**t.
! 1) forward substitution with l
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute l \ b -> b [ (l \p**t * b) ]
call stdlib${ii}$_${ri}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (l \p**t * b) ]
call stdlib${ii}$_${ri}$lacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_${ri}$lacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_${ri}$gtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info)
! 3) backward substitution with l**t
if( n>1_${ik}$ ) then
! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ]
call stdlib${ii}$_${ri}$trsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), &
ldb)
! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$sytrs_aa
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info )
!! CSYTRS_AA solves a system of linear equations A*X = B with a complex
!! symmetric matrix A using the factorization A = U**T*T*U or
!! A = L*T*L**T computed by CSYTRF_AA.
! -- 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(in) :: n, nrhs, lda, ldb, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
logical(lk) :: lquery, upper
integer(${ik}$) :: k, kp, lwkopt
! Intrinsic Functions
! Executable Statements
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( 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}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n-2 ) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYTRS_AA', -info )
return
else if( lquery ) then
lwkopt = (3_${ik}$*n-2)
work( 1_${ik}$ ) = lwkopt
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u**t*t*u.
! 1) forward substitution with u**t
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute u**t \ b -> b [ (u**t \p**t * b) ]
call stdlib${ii}$_ctrsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (u**t \p**t * b) ]
call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_cgtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info )
! 3) backward substitution with u
if( n>1_${ik}$ ) then
! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ]
call stdlib${ii}$_ctrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
! pivot, p * b -> b [ p * (u**t \ (t \ (u \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
else
! solve a*x = b, where a = l*t*l**t.
! 1) forward substitution with l
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute l \ b -> b [ (l \p**t * b) ]
call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (l \p**t * b) ]
call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_cgtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info)
! 3) backward substitution with l**t
if( n>1_${ik}$ ) then
! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ]
call stdlib${ii}$_ctrsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_csytrs_aa
pure module subroutine stdlib${ii}$_zsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info )
!! ZSYTRS_AA solves a system of linear equations A*X = B with a complex
!! symmetric matrix A using the factorization A = U**T*T*U or
!! A = L*T*L**T computed by ZSYTRF_AA.
! -- 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(in) :: n, nrhs, lda, ldb, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
logical(lk) :: lquery, upper
integer(${ik}$) :: k, kp, lwkopt
! Intrinsic Functions
! Executable Statements
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( 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}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n-2 ) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRS_AA', -info )
return
else if( lquery ) then
lwkopt = (3_${ik}$*n-2)
work( 1_${ik}$ ) = lwkopt
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u**t*t*u.
! 1) forward substitution with u**t
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute u**t \ b -> b [ (u**t \p**t * b) ]
call stdlib${ii}$_ztrsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (u**t \p**t * b) ]
call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_zgtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info )
! 3) backward substitution with u
if( n>1_${ik}$ ) then
! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ]
call stdlib${ii}$_ztrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
else
! solve a*x = b, where a = l*t*l**t.
! 1) forward substitution with l
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute l \ b -> b [ (l \p**t * b) ]
call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (l \p**t * b) ]
call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_zgtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info)
! 3) backward substitution with l**t
if( n>1_${ik}$ ) then
! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ]
call stdlib${ii}$_ztrsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_zsytrs_aa
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info )
!! ZSYTRS_AA: solves a system of linear equations A*X = B with a complex
!! symmetric matrix A using the factorization A = U**T*T*U or
!! A = L*T*L**T computed by ZSYTRF_AA.
! -- 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(in) :: n, nrhs, lda, ldb, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
logical(lk) :: lquery, upper
integer(${ik}$) :: k, kp, lwkopt
! Intrinsic Functions
! Executable Statements
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( 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}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n-2 ) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYTRS_AA', -info )
return
else if( lquery ) then
lwkopt = (3_${ik}$*n-2)
work( 1_${ik}$ ) = lwkopt
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u**t*t*u.
! 1) forward substitution with u**t
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute u**t \ b -> b [ (u**t \p**t * b) ]
call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (u**t \p**t * b) ]
call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_${ci}$gtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info )
! 3) backward substitution with u
if( n>1_${ik}$ ) then
! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ]
call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
else
! solve a*x = b, where a = l*t*l**t.
! 1) forward substitution with l
if( n>1_${ik}$ ) then
! pivot, p**t * b -> b
do k = 1, n
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
! compute l \ b -> b [ (l \p**t * b) ]
call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
end if
! 2) solve with triangular matrix t
! compute t \ b -> b [ t \ (l \p**t * b) ]
call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$)
if( n>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ )
end if
call stdlib${ii}$_${ci}$gtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info)
! 3) backward substitution with l**t
if( n>1_${ik}$ ) then
! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ]
call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),&
ldb)
! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ]
do k = n, 1, -1
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$sytrs_aa
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_solve_ldl_comp2
