#:include "common.fypp"
submodule(stdlib_lapack_eig_svd_lsq) stdlib_lapack_eigv_gen
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
module subroutine stdlib${ii}$_sgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, &
!! SGEEV computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, &
minwrk, nout
real(sp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -9_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_shseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_shseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_strevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else if( wantvr ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_shseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_strevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else
minwrk = 3_${ik}$*n
call stdlib${ii}$_shseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_sgebal( 'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = ibal + n
iwrk = itau + n
call stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_slacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'E', 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_shseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 4*n, prefer n + n + 2*n*nb)
call stdlib${ii}$_strevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (workspace: need n)
call stdlib${ii}$_sgebak( 'B', 'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_srot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (workspace: need n)
call stdlib${ii}$_sgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_srot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sgeev
module subroutine stdlib${ii}$_dgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, &
!! DGEEV computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, &
minwrk, nout
real(dp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -9_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_dhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_dhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_dtrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else if( wantvr ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_dhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_dtrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else
minwrk = 3_${ik}$*n
call stdlib${ii}$_dhseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_dgebal( 'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = ibal + n
iwrk = itau + n
call stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_dlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'E', 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_dhseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 4*n, prefer n + n + 2*n*nb)
call stdlib${ii}$_dtrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (workspace: need n)
call stdlib${ii}$_dgebak( 'B', 'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_drot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (workspace: need n)
call stdlib${ii}$_dgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_drot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dgeev
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$geev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, &
!! DGEEV: computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, &
minwrk, nout
real(${rk}$) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(${rk}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -9_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ri}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_${ri}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else if( wantvr ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_${ri}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else
minwrk = 3_${ik}$*n
call stdlib${ii}$_${ri}$hseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ri}$gebal( 'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = ibal + n
iwrk = itau + n
call stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_${ri}$lacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'E', 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_${ri}$hseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 4*n, prefer n + n + 2*n*nb)
call stdlib${ii}$_${ri}$trevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (workspace: need n)
call stdlib${ii}$_${ri}$gebak( 'B', 'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_i${ri}$amax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_${ri}$rot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (workspace: need n)
call stdlib${ii}$_${ri}$gebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_i${ri}$amax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_${ri}$rot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$geev
#:endif
#:endfor
module subroutine stdlib${ii}$_cgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, &
!! CGEEV computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, &
maxwrk, minwrk, nout
real(sp) :: anrm, bignum, cscale, eps, scl, smlnum
complex(sp) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_chseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
if( wantvl ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_ctrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_chseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_ctrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_chseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_chseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, hswork, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_cgebal( 'B', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_clacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'E', 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_chseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need 2*n)
irwork = ibal + n
call stdlib${ii}$_ctrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork( irwork ), n, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_cgebak( 'B', 'L', n, ilo, ihi, rwork( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_scnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_csscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vl( k, i ),KIND=sp)**2_${ik}$ +aimag( vl( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_cscal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=sp), zero,KIND=sp)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_cgebak( 'B', 'R', n, ilo, ihi, rwork( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_scnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_csscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vr( k, i ),KIND=sp)**2_${ik}$ +aimag( vr( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_cscal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=sp), zero,KIND=sp)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cgeev
module subroutine stdlib${ii}$_zgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, &
!! ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, &
maxwrk, minwrk, nout
real(dp) :: anrm, bignum, cscale, eps, scl, smlnum
complex(dp) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_zhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
if( wantvl ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_ztrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_zhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_ztrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_zhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_zhseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, hswork, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_zgebal( 'B', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_zlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'E', 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_zhseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need 2*n)
irwork = ibal + n
call stdlib${ii}$_ztrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork( irwork ), n, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_zgebak( 'B', 'L', n, ilo, ihi, rwork( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_dznrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vl( k, i ),KIND=dp)**2_${ik}$ +aimag( vl( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_zscal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=dp), zero,KIND=dp)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_zgebak( 'B', 'R', n, ilo, ihi, rwork( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_dznrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vr( k, i ),KIND=dp)**2_${ik}$ +aimag( vr( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_zscal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=dp), zero,KIND=dp)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zgeev
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$geev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, &
!! ZGEEV: computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, &
maxwrk, minwrk, nout
real(${ck}$) :: anrm, bignum, cscale, eps, scl, smlnum
complex(${ck}$) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ci}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
if( wantvl ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_${ci}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_${ci}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_${ci}$hseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, hswork, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ci}$gebal( 'B', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_${ci}$lacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'E', 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_${ci}$hseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need 2*n)
irwork = ibal + n
call stdlib${ii}$_${ci}$trevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork( irwork ), n, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$gebak( 'B', 'L', n, ilo, ihi, rwork( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vl( k, i ),KIND=${ck}$)**2_${ik}$ +aimag( vl( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_${ci}$scal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$gebak( 'B', 'R', n, ilo, ihi, rwork( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vr( k, i ),KIND=${ck}$)**2_${ik}$ +aimag( vr( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_${ci}$scal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$geev
#:endif
#:endfor
module subroutine stdlib${ii}$_sgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, &
!! SGEEVX computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_sp of the LAPACK
!! Users' Guide.
ilo, ihi, scale, abnrm,rconde, rcondv, work, lwork, iwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(sp), intent(out) :: abnrm
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),&
work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(sp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_shseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_strevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_shseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
else if( wantvr ) then
call stdlib${ii}$_strevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_shseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
else
if( wntsnn ) then
call stdlib${ii}$_shseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
else
call stdlib${ii}$_shseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.wntsnn )minwrk = max( minwrk, n*n+6*n )
maxwrk = max( maxwrk, hswork )
if( .not.wntsnn )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
else
minwrk = 3_${ik}$*n
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )minwrk = max( minwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, 3_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_sgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_slange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (workspace: need 2*n, prefer n+n*nb)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_slacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( job, 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_shseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 3*n, prefer n + 2*n*nb)
call stdlib${ii}$_strevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
! compute condition numbers if desired
! (workspace: need n*n+6*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_strsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, iwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_sgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
call stdlib${ii}$_slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_srot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_sgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
call stdlib${ii}$_slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_srot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sgeevx
module subroutine stdlib${ii}$_dgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, &
!! DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_dp of the LAPACK
!! Users' Guide.
ilo, ihi, scale, abnrm,rconde, rcondv, work, lwork, iwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(dp), intent(out) :: abnrm
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),&
work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(dp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_dhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_dtrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_dhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
else if( wantvr ) then
call stdlib${ii}$_dtrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_dhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
else
if( wntsnn ) then
call stdlib${ii}$_dhseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
else
call stdlib${ii}$_dhseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.wntsnn )minwrk = max( minwrk, n*n+6*n )
maxwrk = max( maxwrk, hswork )
if( .not.wntsnn )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
else
minwrk = 3_${ik}$*n
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )minwrk = max( minwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, 3_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_dgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_dlange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (workspace: need 2*n, prefer n+n*nb)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_dlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( job, 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_dhseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 3*n, prefer n + 2*n*nb)
call stdlib${ii}$_dtrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
! compute condition numbers if desired
! (workspace: need n*n+6*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_dtrsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, iwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_dgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
call stdlib${ii}$_dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_drot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_dgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
call stdlib${ii}$_dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_drot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dgeevx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, &
!! DGEEVX: computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_${rk}$ of the LAPACK
!! Users' Guide.
ilo, ihi, scale, abnrm,rconde, rcondv, work, lwork, iwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(${rk}$), intent(out) :: abnrm
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),&
work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(${rk}$) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(${rk}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ri}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_${ri}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
else if( wantvr ) then
call stdlib${ii}$_${ri}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
else
if( wntsnn ) then
call stdlib${ii}$_${ri}$hseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
else
call stdlib${ii}$_${ri}$hseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.wntsnn )minwrk = max( minwrk, n*n+6*n )
maxwrk = max( maxwrk, hswork )
if( .not.wntsnn )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
else
minwrk = 3_${ik}$*n
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )minwrk = max( minwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, 3_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_${ri}$gebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_${ri}$lange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (workspace: need 2*n, prefer n+n*nb)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_${ri}$lacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( job, 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_${ri}$hseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 3*n, prefer n + 2*n*nb)
call stdlib${ii}$_${ri}$trevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
! compute condition numbers if desired
! (workspace: need n*n+6*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_${ri}$trsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, iwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_${ri}$gebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_${ri}$rot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_${ri}$gebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_${ri}$rot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$geevx
#:endif
#:endfor
module subroutine stdlib${ii}$_cgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, &
!! CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_sp of the LAPACK
!! Users' Guide.
ihi, scale, abnrm, rconde,rcondv, work, lwork, rwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(sp), intent(out) :: abnrm
! Array Arguments
real(sp), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(sp) :: anrm, bignum, cscale, eps, scl, smlnum
complex(sp) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) &
.or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_chseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_ctrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_chseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
call stdlib${ii}$_ctrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_chseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
if( wntsnn ) then
call stdlib${ii}$_chseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_chseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
else
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, 2_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_cgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_clange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_clacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( job, 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_chseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need n)
call stdlib${ii}$_ctrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork, n, ierr )
end if
! compute condition numbers if desired
! (cworkspace: need n*n+2*n unless sense = 'e')
! (rworkspace: need 2*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_ctrsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, rwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_cgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_scnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_csscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vl( k, i ),KIND=sp)**2_${ik}$ +aimag( vl( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_cscal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=sp), zero,KIND=sp)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_cgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_scnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_csscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vr( k, i ),KIND=sp)**2_${ik}$ +aimag( vr( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_cscal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=sp), zero,KIND=sp)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cgeevx
module subroutine stdlib${ii}$_zgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, &
!! ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_dp of the LAPACK
!! Users' Guide.
ihi, scale, abnrm, rconde,rcondv, work, lwork, rwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(dp), intent(out) :: abnrm
! Array Arguments
real(dp), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(dp) :: anrm, bignum, cscale, eps, scl, smlnum
complex(dp) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) &
.or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_zhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_ztrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_zhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
call stdlib${ii}$_ztrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_zhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
if( wntsnn ) then
call stdlib${ii}$_zhseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_zhseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
else
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, 2_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_zgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_zlange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_zlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( job, 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_zhseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need n)
call stdlib${ii}$_ztrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork, n, ierr )
end if
! compute condition numbers if desired
! (cworkspace: need n*n+2*n unless sense = 'e')
! (rworkspace: need 2*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_ztrsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, rwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_zgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_dznrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vl( k, i ),KIND=dp)**2_${ik}$ +aimag( vl( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_zscal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=dp), zero,KIND=dp)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_zgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_dznrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vr( k, i ),KIND=dp)**2_${ik}$ +aimag( vr( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_zscal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=dp), zero,KIND=dp)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zgeevx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, &
!! ZGEEVX: computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_${ck}$ of the LAPACK
!! Users' Guide.
ihi, scale, abnrm, rconde,rcondv, work, lwork, rwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(${ck}$), intent(out) :: abnrm
! Array Arguments
real(${ck}$), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(${ck}$) :: anrm, bignum, cscale, eps, scl, smlnum
complex(${ck}$) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) &
.or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ci}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_${ci}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
call stdlib${ii}$_${ci}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
if( wntsnn ) then
call stdlib${ii}$_${ci}$hseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_${ci}$hseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
else
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, 2_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_${ci}$gebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_${ci}$lange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_${ci}$lacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( job, 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_${ci}$hseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$trevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork, n, ierr )
end if
! compute condition numbers if desired
! (cworkspace: need n*n+2*n unless sense = 'e')
! (rworkspace: need 2*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_${ci}$trsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, rwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_${ci}$gebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vl( k, i ),KIND=${ck}$)**2_${ik}$ +aimag( vl( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_${ci}$scal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_${ci}$gebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vr( k, i ),KIND=${ck}$)**2_${ik}$ +aimag( vr( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_${ci}$scal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$geevx
#:endif
#:endfor
module subroutine stdlib${ii}$_sgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, &
!! SGEES computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A matrix is in real Schur form if it is upper quasi-triangular with
!! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
!! form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
bwork, info )
! -- lapack driver 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) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_s) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, maxwrk, minwrk
real(sp) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_shseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_shseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_sgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (workspace: none needed)
call stdlib${ii}$_strsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, &
work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond )
if( icond>0_${ik}$ )info = n + icond
end if
if( wantvs ) then
! undo balancing
! (workspace: need n)
call stdlib${ii}$_sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_scopy( n, a, lda+1, wr, 1_${ik}$ )
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), &
ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_sswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_sswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_sswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
! undo scaling for the imaginary part of the eigenvalues
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sgees
module subroutine stdlib${ii}$_dgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, &
!! DGEES computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A matrix is in real Schur form if it is upper quasi-triangular with
!! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
!! form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
bwork, info )
! -- lapack driver 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) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_d) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, maxwrk, minwrk
real(dp) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_dhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_dhseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_dgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (workspace: none needed)
call stdlib${ii}$_dtrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, &
work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond )
if( icond>0_${ik}$ )info = n + icond
end if
if( wantvs ) then
! undo balancing
! (workspace: need n)
call stdlib${ii}$_dgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_dcopy( n, a, lda+1, wr, 1_${ik}$ )
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), &
ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_dswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_dswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_dswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
! undo scaling for the imaginary part of the eigenvalues
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dgees
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$gees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, &
!! DGEES: computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A matrix is in real Schur form if it is upper quasi-triangular with
!! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
!! form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
bwork, info )
! -- lapack driver 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) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_${ri}$) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, maxwrk, minwrk
real(${rk}$) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(${rk}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ri}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_${ri}$hseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ri}$gebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (workspace: none needed)
call stdlib${ii}$_${ri}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, &
work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond )
if( icond>0_${ik}$ )info = n + icond
end if
if( wantvs ) then
! undo balancing
! (workspace: need n)
call stdlib${ii}$_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ri}$copy( n, a, lda+1, wr, 1_${ik}$ )
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), &
ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_${ri}$swap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_${ri}$swap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
! undo scaling for the imaginary part of the eigenvalues
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$gees
#:endif
#:endfor
module subroutine stdlib${ii}$_cgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, &
!! CGEES computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A complex matrix is in Schur form if it is upper triangular.
rwork, bwork, info )
! -- lapack driver 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) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_c) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, &
minwrk
real(sp) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_chseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_chseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=sp)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_cgebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (cworkspace: none)
! (rworkspace: none)
call stdlib${ii}$_ctrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( &
iwrk ), lwork-iwrk+1, icond )
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_cgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_ccopy( n, a, lda+1, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cgees
module subroutine stdlib${ii}$_zgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, &
!! ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A complex matrix is in Schur form if it is upper triangular.
rwork, bwork, info )
! -- lapack driver 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) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_z) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, &
minwrk
real(dp) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_zhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_zhseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=dp)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_zgebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (cworkspace: none)
! (rworkspace: none)
call stdlib${ii}$_ztrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( &
iwrk ), lwork-iwrk+1, icond )
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_zgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_zcopy( n, a, lda+1, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zgees
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$gees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, &
!! ZGEES: computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A complex matrix is in Schur form if it is upper triangular.
rwork, bwork, info )
! -- lapack driver 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) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_${ci}$) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, &
minwrk
real(${ck}$) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ci}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_${ci}$hseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=${ck}$)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ci}$gebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (cworkspace: none)
! (rworkspace: none)
call stdlib${ii}$_${ci}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( &
iwrk ), lwork-iwrk+1, icond )
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ci}$copy( n, a, lda+1, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$gees
#:endif
#:endfor
module subroutine stdlib${ii}$_sgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, &
!! SGEESX computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_sp of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A real matrix is in real Schur form if it is upper quasi-triangular
!! with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
!! the form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
rconde, rcondv, work, lwork,iwork, liwork, bwork, info )
! -- lapack driver 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) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n
real(sp), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_s) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, &
wantsv, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, lwrk, liwrk, maxwrk, minwrk
real(sp) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "rworkspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! iworkspace refers to integer workspace.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_shseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_strsen later
! in the code.)
if( info==0_${ik}$ ) then
liwrk = 1_${ik}$
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_shseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, n + ( n*n )/2_${ik}$ )
if( wantsv .or. wantsb )liwrk = ( n*n )/4_${ik}$
end if
iwork( 1_${ik}$ ) = liwrk
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<1_${ik}$ .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_sgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (rworkspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (rworkspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (rworkspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (rworkspace: if sense is not 'n', need n+2*sdim*(n-sdim)
! otherwise, need n )
! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim)
! otherwise, need 0 )
call stdlib${ii}$_strsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond )
if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) )
if( icond==-15_${ik}$ ) then
! not enough real workspace
info = -16_${ik}$
else if( icond==-17_${ik}$ ) then
! not enough integer workspace
info = -18_${ik}$
else if( icond>0_${ik}$ ) then
! stdlib${ii}$_strsen failed to reorder or to restore standard schur form
info = icond + n
end if
end if
if( wantvs ) then
! undo balancing
! (rworkspace: need n)
call stdlib${ii}$_sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_scopy( n, a, lda+1, wr, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_sswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_sswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_sswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
if( wantsv .or. wantsb ) then
iwork( 1_${ik}$ ) = sdim*(n-sdim)
else
iwork( 1_${ik}$ ) = 1_${ik}$
end if
return
end subroutine stdlib${ii}$_sgeesx
module subroutine stdlib${ii}$_dgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, &
!! DGEESX computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_dp of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A real matrix is in real Schur form if it is upper quasi-triangular
!! with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
!! the form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
rconde, rcondv, work, lwork,iwork, liwork, bwork, info )
! -- lapack driver 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) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n
real(dp), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_d) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, &
wantsv, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, liwrk, lwrk, maxwrk, minwrk
real(dp) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "rworkspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! iworkspace refers to integer workspace.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_dhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_dtrsen later
! in the code.)
if( info==0_${ik}$ ) then
liwrk = 1_${ik}$
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_dhseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, n + ( n*n )/2_${ik}$ )
if( wantsv .or. wantsb )liwrk = ( n*n )/4_${ik}$
end if
iwork( 1_${ik}$ ) = liwrk
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<1_${ik}$ .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_dgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (rworkspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (rworkspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (rworkspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (rworkspace: if sense is not 'n', need n+2*sdim*(n-sdim)
! otherwise, need n )
! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim)
! otherwise, need 0 )
call stdlib${ii}$_dtrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond )
if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) )
if( icond==-15_${ik}$ ) then
! not enough real workspace
info = -16_${ik}$
else if( icond==-17_${ik}$ ) then
! not enough integer workspace
info = -18_${ik}$
else if( icond>0_${ik}$ ) then
! stdlib${ii}$_dtrsen failed to reorder or to restore standard schur form
info = icond + n
end if
end if
if( wantvs ) then
! undo balancing
! (rworkspace: need n)
call stdlib${ii}$_dgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_dcopy( n, a, lda+1, wr, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_dswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_dswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_dswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
if( wantsv .or. wantsb ) then
iwork( 1_${ik}$ ) = max( 1_${ik}$, sdim*( n-sdim ) )
else
iwork( 1_${ik}$ ) = 1_${ik}$
end if
return
end subroutine stdlib${ii}$_dgeesx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$geesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, &
!! DGEESX: computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_${rk}$ of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A real matrix is in real Schur form if it is upper quasi-triangular
!! with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
!! the form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
rconde, rcondv, work, lwork,iwork, liwork, bwork, info )
! -- lapack driver 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) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n
real(${rk}$), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_${ri}$) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, &
wantsv, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, liwrk, lwrk, maxwrk, minwrk
real(${rk}$) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(${rk}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "rworkspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! iworkspace refers to integer workspace.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ri}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_${ri}$trsen later
! in the code.)
if( info==0_${ik}$ ) then
liwrk = 1_${ik}$
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_${ri}$hseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, n + ( n*n )/2_${ik}$ )
if( wantsv .or. wantsb )liwrk = ( n*n )/4_${ik}$
end if
iwork( 1_${ik}$ ) = liwrk
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<1_${ik}$ .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ri}$gebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (rworkspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (rworkspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (rworkspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (rworkspace: if sense is not 'n', need n+2*sdim*(n-sdim)
! otherwise, need n )
! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim)
! otherwise, need 0 )
call stdlib${ii}$_${ri}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond )
if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) )
if( icond==-15_${ik}$ ) then
! not enough real workspace
info = -16_${ik}$
else if( icond==-17_${ik}$ ) then
! not enough integer workspace
info = -18_${ik}$
else if( icond>0_${ik}$ ) then
! stdlib${ii}$_${ri}$trsen failed to reorder or to restore standard schur form
info = icond + n
end if
end if
if( wantvs ) then
! undo balancing
! (rworkspace: need n)
call stdlib${ii}$_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ri}$copy( n, a, lda+1, wr, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_${ri}$swap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_${ri}$swap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
if( wantsv .or. wantsb ) then
iwork( 1_${ik}$ ) = max( 1_${ik}$, sdim*( n-sdim ) )
else
iwork( 1_${ik}$ ) = 1_${ik}$
end if
return
end subroutine stdlib${ii}$_${ri}$geesx
#:endif
#:endfor
module subroutine stdlib${ii}$_cgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, &
!! CGEESX computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_sp of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A complex matrix is in Schur form if it is upper triangular.
rcondv, work, lwork, rwork,bwork, info )
! -- lapack driver 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) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
real(sp), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_c) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, &
maxwrk, minwrk
real(sp) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_chseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_ctrsen later
! in the code.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_chseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=sp)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, ( n*n )/2_${ik}$ )
end if
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_cgebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim)
! otherwise, need none )
! (rworkspace: none)
call stdlib${ii}$_ctrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,icond )
if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( icond==-14_${ik}$ ) then
! not enough complex workspace
info = -15_${ik}$
end if
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_cgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_ccopy( n, a, lda+1, w, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cgeesx
module subroutine stdlib${ii}$_zgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, &
!! ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_dp of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A complex matrix is in Schur form if it is upper triangular.
rcondv, work, lwork, rwork,bwork, info )
! -- lapack driver 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) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
real(dp), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_z) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, &
maxwrk, minwrk
real(dp) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_zhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_ztrsen later
! in the code.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_zhseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=dp)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, ( n*n )/2_${ik}$ )
end if
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_zgebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim)
! otherwise, need none )
! (rworkspace: none)
call stdlib${ii}$_ztrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,icond )
if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( icond==-14_${ik}$ ) then
! not enough complex workspace
info = -15_${ik}$
end if
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_zgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_zcopy( n, a, lda+1, w, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zgeesx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$geesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, &
!! ZGEESX: computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_${ck}$ of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A complex matrix is in Schur form if it is upper triangular.
rcondv, work, lwork, rwork,bwork, info )
! -- lapack driver 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) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
real(${ck}$), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_${ci}$) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, &
maxwrk, minwrk
real(${ck}$) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ci}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_${ci}$trsen later
! in the code.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_${ci}$hseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=${ck}$)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, ( n*n )/2_${ik}$ )
end if
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ci}$gebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim)
! otherwise, need none )
! (rworkspace: none)
call stdlib${ii}$_${ci}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,icond )
if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( icond==-14_${ik}$ ) then
! not enough complex workspace
info = -15_${ik}$
end if
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ci}$copy( n, a, lda+1, w, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$geesx
#:endif
#:endfor
module subroutine stdlib${ii}$_sggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,&
!! SGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork,info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
else if( lwork<max( 1_${ik}$, 8_${ik}$*n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_sgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, 8_${ik}$*n, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_sormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_sgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, work, &
-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_sorgqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_slaqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_slaqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = real( lwkopt,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_sgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_sgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_slaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = real( lwkopt,KIND=sp)
return
end subroutine stdlib${ii}$_sggev3
module subroutine stdlib${ii}$_dggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,&
!! DGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork,info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
else if( lwork<max( 1_${ik}$, 8_${ik}$*n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_dgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max(1_${ik}$, 8_${ik}$*n, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work, -1_${ik}$,ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_dorgqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_dgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dlaqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_dgghd3( 'N', 'N', n, 1_${ik}$, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, work, -&
1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dlaqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_dggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_dgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_dgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_dlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dggev3
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$ggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,&
!! DGGEV3: computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork,info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, lwkopt
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
else if( lwork<max( 1_${ik}$, 8_${ik}$*n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ri}$geqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max(1_${ik}$, 8_${ik}$*n, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work, -1_${ik}$,ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_${ri}$orgqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_${ri}$gghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$laqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_${ri}$gghd3( 'N', 'N', n, 1_${ik}$, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, work, -&
1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$laqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_${ri}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ri}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_${ri}$gghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ri}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$ggev3
#:endif
#:endfor
module subroutine stdlib${ii}$_cggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! CGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(sp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=sp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -15_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_cgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( n, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_cunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_cungqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_cgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_claqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_cgghd3( 'N', 'N', n, 1_${ik}$, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, work, -&
1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_claqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'E' )*stdlib${ii}$_slamch( 'B' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_cggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_cgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk,ierr )
else
call stdlib${ii}$_cgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_claqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
return
end subroutine stdlib${ii}$_cggev3
module subroutine stdlib${ii}$_zggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! ZGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(dp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=dp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -15_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_zgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_zunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_zungqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_zgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_zlaqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_zgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_zlaqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'E' )*stdlib${ii}$_dlamch( 'B' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_zggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_zgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_zgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_zlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp)
return
end subroutine stdlib${ii}$_zggev3
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$ggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! ZGGEV3: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkopt
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(${ck}$) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -15_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ci}$geqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_${ci}$ungqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_${ci}$gghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ci}$laqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_${ci}$gghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ci}$laqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'E' )*stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_${ci}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ci}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_${ci}$gghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ci}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$)
return
end subroutine stdlib${ii}$_${ci}$ggev3
#:endif
#:endfor
module subroutine stdlib${ii}$_sggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, &
!! SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, maxwrk, minwrk
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
minwrk = max( 1_${ik}$, 8_${ik}$*n )
maxwrk = max( 1_${ik}$, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
if( ilvl ) then
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_sgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
! (workspace: need 6*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sggev
module subroutine stdlib${ii}$_dggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, &
!! DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, maxwrk, minwrk
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
minwrk = max( 1_${ik}$, 8_${ik}$*n )
maxwrk = max( 1_${ik}$, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
if( ilvl ) then
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_dggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_dgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
! (workspace: need 6*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dggev
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, &
!! DGGEV: computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, maxwrk, minwrk
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
minwrk = max( 1_${ik}$, 8_${ik}$*n )
maxwrk = max( 1_${ik}$, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
if( ilvl ) then
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_${ri}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_${ri}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
! (workspace: need 6*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$ggev
#:endif
#:endfor
module subroutine stdlib${ii}$_cggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! CGGEV computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkmin, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(sp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=sp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'E' )*stdlib${ii}$_slamch( 'B' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_cggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (complex workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_cgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
! (real workspace: need 2*n)
! (complex workspace: need 2*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cggev
module subroutine stdlib${ii}$_zggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkmin, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(dp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=dp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'E' )*stdlib${ii}$_dlamch( 'B' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_zggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (complex workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_zgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
! (real workspace: need 2*n)
! (complex workspace: need 2*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zggev
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! ZGGEV: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver 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) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkmin, lwkopt
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(${ck}$) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<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 = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'E' )*stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_${ci}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (complex workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_${ci}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
! (real workspace: need 2*n)
! (complex workspace: need 2*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$ggev
#:endif
#:endfor
module subroutine stdlib${ii}$_sggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alphar, alphai, &
!! SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
beta, vl, ldvl, vr, ldvr, ilo,ihi, lscale, rscale, abnrm, bbnrm, rconde,rcondv, work, lwork, &
iwork, bwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(sp), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), lscale(*), rconde(*), rcondv(*)&
, rscale(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, pair, wantsb, wantse, &
wantsn, wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk, mm
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( noscl .or. stdlib_lsame( balanc, 'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) &
then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -14_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
if( noscl .and. .not.ilv ) then
minwrk = 2_${ik}$*n
else
minwrk = 6_${ik}$*n
end if
if( wantse ) then
minwrk = 10_${ik}$*n
else if( wantsv .or. wantsb ) then
minwrk = 2_${ik}$*n*( n + 4_${ik}$ ) + 16_${ik}$
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -26_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_sggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,work, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_slange( '1', n, n, a, lda, work( 1_${ik}$ ) )
if( ilascl ) then
work( 1_${ik}$ ) = abnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = work( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_slange( '1', n, n, b, ldb, work( 1_${ik}$ ) )
if( ilbscl ) then
work( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = work( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_sgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr, work,lwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 130
end if
! compute eigenvectors and estimate condition numbers if desired
! (workspace: stdlib${ii}$_stgevc: need 6*n
! stdlib${ii}$_stgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b',
! need n otherwise )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_stgevc) and estimate condition
! numbers (stdlib${ii}$_stgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to recalculate
! eigenvectors and estimate one condition numbers at a time.
pair = .false.
loop_20: do i = 1, n
if( pair ) then
pair = .false.
cycle loop_20
end if
mm = 1_${ik}$
if( i<n ) then
if( a( i+1, i )/=zero ) then
pair = .true.
mm = 2_${ik}$
end if
end if
do j = 1, n
bwork( j ) = .false.
end do
if( mm==1_${ik}$ ) then
bwork( i ) = .true.
else if( mm==2_${ik}$ ) then
bwork( i ) = .true.
bwork( i+1 ) = .true.
end if
iwrk = mm*n + 1_${ik}$
iwrk1 = iwrk + mm*n
! compute a pair of left and right eigenvectors.
! (compute workspace: need up to 4*n + 6*n)
if( wantse .or. wantsb ) then
call stdlib${ii}$_stgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, mm, m,work( iwrk1 ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
call stdlib${ii}$_stgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), mm, m, work( iwrk1 ),lwork-iwrk1+1, iwork,&
ierr )
end do loop_20
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_sggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_70: do jc = 1, n
if( alphai( jc )<zero )cycle loop_70
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_70
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_70
end if
if( ilvr ) then
call stdlib${ii}$_sggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_120: do jc = 1, n
if( alphai( jc )<zero )cycle loop_120
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_120
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_120
end if
! undo scaling if necessary
130 continue
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sggevx
module subroutine stdlib${ii}$_dggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alphar, alphai, &
!! DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
beta, vl, ldvl, vr, ldvr, ilo,ihi, lscale, rscale, abnrm, bbnrm, rconde,rcondv, work, lwork, &
iwork, bwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(dp), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), lscale(*), rconde(*), rcondv(*)&
, rscale(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, pair, wantsb, wantse, &
wantsn, wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk, mm
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc,'S' ) .or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -14_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
if( noscl .and. .not.ilv ) then
minwrk = 2_${ik}$*n
else
minwrk = 6_${ik}$*n
end if
if( wantse .or. wantsb ) then
minwrk = 10_${ik}$*n
end if
if( wantsv .or. wantsb ) then
minwrk = max( minwrk, 2_${ik}$*n*( n + 4_${ik}$ ) + 16_${ik}$ )
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -26_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_dggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,work, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_dlange( '1', n, n, a, lda, work( 1_${ik}$ ) )
if( ilascl ) then
work( 1_${ik}$ ) = abnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = work( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_dlange( '1', n, n, b, ldb, work( 1_${ik}$ ) )
if( ilbscl ) then
work( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = work( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_dgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr, work,lwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 130
end if
! compute eigenvectors and estimate condition numbers if desired
! (workspace: stdlib${ii}$_dtgevc: need 6*n
! stdlib${ii}$_dtgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b',
! need n otherwise )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_dtgevc) and estimate condition
! numbers (stdlib${ii}$_dtgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to recalculate
! eigenvectors and estimate one condition numbers at a time.
pair = .false.
loop_20: do i = 1, n
if( pair ) then
pair = .false.
cycle loop_20
end if
mm = 1_${ik}$
if( i<n ) then
if( a( i+1, i )/=zero ) then
pair = .true.
mm = 2_${ik}$
end if
end if
do j = 1, n
bwork( j ) = .false.
end do
if( mm==1_${ik}$ ) then
bwork( i ) = .true.
else if( mm==2_${ik}$ ) then
bwork( i ) = .true.
bwork( i+1 ) = .true.
end if
iwrk = mm*n + 1_${ik}$
iwrk1 = iwrk + mm*n
! compute a pair of left and right eigenvectors.
! (compute workspace: need up to 4*n + 6*n)
if( wantse .or. wantsb ) then
call stdlib${ii}$_dtgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, mm, m,work( iwrk1 ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
call stdlib${ii}$_dtgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), mm, m, work( iwrk1 ),lwork-iwrk1+1, iwork,&
ierr )
end do loop_20
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_dggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_70: do jc = 1, n
if( alphai( jc )<zero )cycle loop_70
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_70
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_70
end if
if( ilvr ) then
call stdlib${ii}$_dggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_120: do jc = 1, n
if( alphai( jc )<zero )cycle loop_120
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_120
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_120
end if
! undo scaling if necessary
130 continue
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dggevx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$ggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alphar, alphai, &
!! DGGEVX: computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
beta, vl, ldvl, vr, ldvr, ilo,ihi, lscale, rscale, abnrm, bbnrm, rconde,rcondv, work, lwork, &
iwork, bwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(${rk}$), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), lscale(*), rconde(*), rcondv(*)&
, rscale(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, pair, wantsb, wantse, &
wantsn, wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk, mm
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc,'S' ) .or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -14_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
if( noscl .and. .not.ilv ) then
minwrk = 2_${ik}$*n
else
minwrk = 6_${ik}$*n
end if
if( wantse .or. wantsb ) then
minwrk = 10_${ik}$*n
end if
if( wantsv .or. wantsb ) then
minwrk = max( minwrk, 2_${ik}$*n*( n + 4_${ik}$ ) + 16_${ik}$ )
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -26_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_${ri}$ggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,work, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_${ri}$lange( '1', n, n, a, lda, work( 1_${ik}$ ) )
if( ilascl ) then
work( 1_${ik}$ ) = abnrm
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = work( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_${ri}$lange( '1', n, n, b, ldb, work( 1_${ik}$ ) )
if( ilbscl ) then
work( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = work( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_${ri}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr, work,lwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 130
end if
! compute eigenvectors and estimate condition numbers if desired
! (workspace: stdlib${ii}$_${ri}$tgevc: need 6*n
! stdlib${ii}$_${ri}$tgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b',
! need n otherwise )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_${ri}$tgevc) and estimate condition
! numbers (stdlib${ii}$_${ri}$tgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to recalculate
! eigenvectors and estimate one condition numbers at a time.
pair = .false.
loop_20: do i = 1, n
if( pair ) then
pair = .false.
cycle loop_20
end if
mm = 1_${ik}$
if( i<n ) then
if( a( i+1, i )/=zero ) then
pair = .true.
mm = 2_${ik}$
end if
end if
do j = 1, n
bwork( j ) = .false.
end do
if( mm==1_${ik}$ ) then
bwork( i ) = .true.
else if( mm==2_${ik}$ ) then
bwork( i ) = .true.
bwork( i+1 ) = .true.
end if
iwrk = mm*n + 1_${ik}$
iwrk1 = iwrk + mm*n
! compute a pair of left and right eigenvectors.
! (compute workspace: need up to 4*n + 6*n)
if( wantse .or. wantsb ) then
call stdlib${ii}$_${ri}$tgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, mm, m,work( iwrk1 ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
call stdlib${ii}$_${ri}$tgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), mm, m, work( iwrk1 ),lwork-iwrk1+1, iwork,&
ierr )
end do loop_20
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_${ri}$ggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_70: do jc = 1, n
if( alphai( jc )<zero )cycle loop_70
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_70
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_70
end if
if( ilvr ) then
call stdlib${ii}$_${ri}$ggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_120: do jc = 1, n
if( alphai( jc )<zero )cycle loop_120
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_120
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_120
end if
! undo scaling if necessary
130 continue
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$ggevx
#:endif
#:endfor
module subroutine stdlib${ii}$_cggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, &
!! CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B) the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! Optionally, it also computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
ldvl, vr, ldvr, ilo, ihi,lscale, rscale, abnrm, bbnrm, rconde, rcondv,work, lwork, rwork, &
iwork, bwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(sp), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, &
wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(sp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=sp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) &
then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -13_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -15_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
minwrk = 2_${ik}$*n
if( wantse ) then
minwrk = 4_${ik}$*n
else if( wantsv .or. wantsb ) then
minwrk = 2_${ik}$*n*( n + 1_${ik}$)
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -25_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (real workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_cggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,rwork, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_clange( '1', n, n, a, lda, rwork( 1_${ik}$ ) )
if( ilascl ) then
rwork( 1_${ik}$ ) = abnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = rwork( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_clange( '1', n, n, b, ldb, rwork( 1_${ik}$ ) )
if( ilbscl ) then
rwork( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = rwork( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_cgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 90
end if
! compute eigenvectors and estimate condition numbers if desired
! stdlib${ii}$_ctgevc: (complex workspace: need 2*n )
! (real workspace: need 2*n )
! stdlib${ii}$_ctgsna: (complex workspace: need 2*n*n if sense='v' or 'b')
! (integer workspace: need n+2 )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work( iwrk ), rwork,ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_ctgevc) and estimate condition
! numbers (stdlib${ii}$_ctgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to
! re-calculate eigenvectors and estimate the condition numbers
! one at a time.
do i = 1, n
do j = 1, n
bwork( j ) = .false.
end do
bwork( i ) = .true.
iwrk = n + 1_${ik}$
iwrk1 = iwrk + n
if( wantse .or. wantsb ) then
call stdlib${ii}$_ctgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
call stdlib${ii}$_ctgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, &
ierr )
end do
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_cggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_50: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_50
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_cggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_80: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_80
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_80
end if
! undo scaling if necessary
90 continue
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cggevx
module subroutine stdlib${ii}$_zggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, &
!! ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B) the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! Optionally, it also computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
ldvl, vr, ldvr, ilo, ihi,lscale, rscale, abnrm, bbnrm, rconde, rcondv,work, lwork, rwork, &
iwork, bwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(dp), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, &
wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(dp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=dp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) &
then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -13_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -15_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
minwrk = 2_${ik}$*n
if( wantse ) then
minwrk = 4_${ik}$*n
else if( wantsv .or. wantsb ) then
minwrk = 2_${ik}$*n*( n + 1_${ik}$)
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -25_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (real workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_zggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,rwork, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_zlange( '1', n, n, a, lda, rwork( 1_${ik}$ ) )
if( ilascl ) then
rwork( 1_${ik}$ ) = abnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = rwork( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_zlange( '1', n, n, b, ldb, rwork( 1_${ik}$ ) )
if( ilbscl ) then
rwork( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = rwork( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_zgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 90
end if
! compute eigenvectors and estimate condition numbers if desired
! stdlib${ii}$_ztgevc: (complex workspace: need 2*n )
! (real workspace: need 2*n )
! stdlib${ii}$_ztgsna: (complex workspace: need 2*n*n if sense='v' or 'b')
! (integer workspace: need n+2 )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work( iwrk ), rwork,ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_ztgevc) and estimate condition
! numbers (stdlib${ii}$_ztgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to
! re-calculate eigenvectors and estimate the condition numbers
! one at a time.
do i = 1, n
do j = 1, n
bwork( j ) = .false.
end do
bwork( i ) = .true.
iwrk = n + 1_${ik}$
iwrk1 = iwrk + n
if( wantse .or. wantsb ) then
call stdlib${ii}$_ztgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
call stdlib${ii}$_ztgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, &
ierr )
end do
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_zggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_50: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_50
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_zggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_80: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_80
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_80
end if
! undo scaling if necessary
90 continue
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zggevx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$ggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, &
!! ZGGEVX: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B) the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! Optionally, it also computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
ldvl, vr, ldvr, ilo, ihi,lscale, rscale, abnrm, bbnrm, rconde, rcondv,work, lwork, rwork, &
iwork, bwork, info )
! -- lapack driver 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) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(${ck}$), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, &
wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(${ck}$) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) &
then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -13_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -15_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
minwrk = 2_${ik}$*n
if( wantse ) then
minwrk = 4_${ik}$*n
else if( wantsv .or. wantsb ) then
minwrk = 2_${ik}$*n*( n + 1_${ik}$)
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -25_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (real workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_${ci}$ggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,rwork, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_${ci}$lange( '1', n, n, a, lda, rwork( 1_${ik}$ ) )
if( ilascl ) then
rwork( 1_${ik}$ ) = abnrm
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = rwork( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_${ci}$lange( '1', n, n, b, ldb, rwork( 1_${ik}$ ) )
if( ilbscl ) then
rwork( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = rwork( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_${ci}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 90
end if
! compute eigenvectors and estimate condition numbers if desired
! stdlib${ii}$_${ci}$tgevc: (complex workspace: need 2*n )
! (real workspace: need 2*n )
! stdlib${ii}$_${ci}$tgsna: (complex workspace: need 2*n*n if sense='v' or 'b')
! (integer workspace: need n+2 )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work( iwrk ), rwork,ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_${ci}$tgevc) and estimate condition
! numbers (stdlib${ii}$_${ci}$tgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to
! re-calculate eigenvectors and estimate the condition numbers
! one at a time.
do i = 1, n
do j = 1, n
bwork( j ) = .false.
end do
bwork( i ) = .true.
iwrk = n + 1_${ik}$
iwrk1 = iwrk + n
if( wantse .or. wantsb ) then
call stdlib${ii}$_${ci}$tgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
call stdlib${ii}$_${ci}$tgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, &
ierr )
end do
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_${ci}$ggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_50: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_50
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_${ci}$ggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_80: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_80
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_80
end if
! undo scaling if necessary
90 continue
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$ggevx
#:endif
#:endfor
module subroutine stdlib${ii}$_sgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, &
!! SGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! SGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl,vsr, ldvsr, work, lwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_s) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(sp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
else if( lwork<6_${ik}$*n+16 .and. .not.lquery ) then
info = -19_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_sgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 6_${ik}$*n+16, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_sormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_sorgqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_sgghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_slaqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_stgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$,ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
safmin = stdlib${ii}$_slamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_slabad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_sgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk, ierr )
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_slaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 40
end if
! sort eigenvalues alpha/beta if desired
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_stgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl )then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphar( i ) )>( &
anrm/anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i )/alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphai( i ) )>( &
anrm/anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i+1 )/alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl )then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i )/safmax )>( bnrmto/bnrm ) .or.( safmin/beta( i ) )>( &
bnrm/bnrmto ) ) then
work( 1_${ik}$ ) = abs(b( i, i )/beta( i ))
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sgges3
module subroutine stdlib${ii}$_dgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, &
!! DGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! DGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl,vsr, ldvsr, work, lwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_d) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(dp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
else if( lwork<6_${ik}$*n+16 .and. .not.lquery ) then
info = -19_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_dgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 6_${ik}$*n+16, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_dorgqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_dgghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dlaqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_dtgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$,ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
safmin = stdlib${ii}$_dlamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_dlabad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_dggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_dgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk,ierr )
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_dlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 50
end if
! sort eigenvalues alpha/beta if desired
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_dtgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
50 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dgges3
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, &
!! DGGES3: computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! DGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl,vsr, ldvsr, work, lwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_${ri}$) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, lwkopt
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(${rk}$) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
else if( lwork<6_${ik}$*n+16 .and. .not.lquery ) then
info = -19_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ri}$geqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 6_${ik}$*n+16, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_${ri}$orgqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_${ri}$gghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$laqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_${ri}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$,ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
safmin = stdlib${ii}$_${ri}$lamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_${ri}$labad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_${ri}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_${ri}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk,ierr )
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_${ri}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 50
end if
! sort eigenvalues alpha/beta if desired
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_${ri}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
50 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$gges3
#:endif
#:endfor
module subroutine stdlib${ii}$_cgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alpha, beta, &
!! CGGES3 computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the generalized complex Schur
!! form (S, T), and optionally left and/or right Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T. The leading
!! columns of VSL and VSR then form an unitary basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! CGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0, and even for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if S
!! and T are upper triangular and, in addition, the diagonal elements
!! of T are non-negative real numbers.
vsl, ldvsl, vsr, ldvsr,work, lwork, rwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_c) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, &
itau, iwrk, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(sp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -14_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -16_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_cgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_cunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_cungqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$,ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_cgghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_claqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, int( work( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_ctgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, sdim,pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$, ierr )
lwkopt = max( lwkopt, int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_cggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_cgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk, ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_claqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 30
end if
! sort eigenvalues alpha/beta if desired
if( wantst ) then
! undo scaling on eigenvalues before selecting
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
call stdlib${ii}$_ctgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
30 continue
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
return
end subroutine stdlib${ii}$_cgges3
module subroutine stdlib${ii}$_zgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alpha, beta, &
!! ZGGES3 computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the generalized complex Schur
!! form (S, T), and optionally left and/or right Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T. The leading
!! columns of VSL and VSR then form an unitary basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! ZGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0, and even for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if S
!! and T are upper triangular and, in addition, the diagonal elements
!! of T are non-negative real numbers.
vsl, ldvsl, vsr, ldvsr,work, lwork, rwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_z) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, &
itau, iwrk, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(dp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -14_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -16_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_zgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_zunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_zungqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_zgghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_zlaqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, int( work( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_ztgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, sdim,pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$, ierr )
lwkopt = max( lwkopt, int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_zggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_zgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk, ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_zlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 30
end if
! sort eigenvalues alpha/beta if desired
if( wantst ) then
! undo scaling on eigenvalues before selecting
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
call stdlib${ii}$_ztgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
30 continue
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp)
return
end subroutine stdlib${ii}$_zgges3
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alpha, beta, &
!! ZGGES3: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the generalized complex Schur
!! form (S, T), and optionally left and/or right Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T. The leading
!! columns of VSL and VSR then form an unitary basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! ZGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0, and even for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if S
!! and T are upper triangular and, in addition, the diagonal elements
!! of T are non-negative real numbers.
vsl, ldvsl, vsr, ldvsr,work, lwork, rwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_${ci}$) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, &
itau, iwrk, lwkopt
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(${ck}$) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -14_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -16_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ci}$geqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_${ci}$ungqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_${ci}$gghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ci}$laqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, int( work( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_${ci}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, sdim,pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$, ierr )
lwkopt = max( lwkopt, int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_${ci}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_${ci}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk, ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_${ci}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 30
end if
! sort eigenvalues alpha/beta if desired
if( wantst ) then
! undo scaling on eigenvalues before selecting
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
call stdlib${ii}$_${ci}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
30 continue
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$)
return
end subroutine stdlib${ii}$_${ci}$gges3
#:endif
#:endfor
module subroutine stdlib${ii}$_sgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alphar, &
!! SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! SGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl, vsr,ldvsr, work, lwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_s) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, maxwrk, minwrk
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(sp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$ )then
minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ )
maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ )
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ &
) )
if( ilvsl ) then
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n, 1_${ik}$, n, &
-1_${ik}$ ) )
end if
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -19_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
safmin = stdlib${ii}$_slamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_slabad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need 6*n + 2*n space for storing balancing factors)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
! perform qz algorithm, computing schur vectors if desired
! (workspace: need n)
iwrk = itau
call stdlib${ii}$_shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 40
end if
! sort eigenvalues alpha/beta if desired
! (workspace: need 4*n+16 )
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_stgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl )then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphar( i ) )>( &
anrm/anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i )/alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphai( i ) )>( &
anrm/anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i+1 )/alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl )then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i )/safmax )>( bnrmto/bnrm ) .or.( safmin/beta( i ) )>( &
bnrm/bnrmto ) ) then
work( 1_${ik}$ ) = abs(b( i, i )/beta( i ))
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
40 continue
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sgges
module subroutine stdlib${ii}$_dgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alphar, &
!! DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! DGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl, vsr,ldvsr, work, lwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_d) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, maxwrk, minwrk
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(dp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$ )then
minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ )
maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ )
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ &
) )
if( ilvsl ) then
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, &
-1_${ik}$ ) )
end if
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -19_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
safmin = stdlib${ii}$_dlamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_dlabad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need 6*n + 2*n space for storing balancing factors)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_dggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_dgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
! perform qz algorithm, computing schur vectors if desired
! (workspace: need n)
iwrk = itau
call stdlib${ii}$_dhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 50
end if
! sort eigenvalues alpha/beta if desired
! (workspace: need 4*n+16 )
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_dtgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
50 continue
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dgges
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$gges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alphar, &
!! DGGES: computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! DGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl, vsr,ldvsr, work, lwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_${ri}$) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, maxwrk, minwrk
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(${rk}$) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$ )then
minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ )
maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ )
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ &
) )
if( ilvsl ) then
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, &
-1_${ik}$ ) )
end if
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -19_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
safmin = stdlib${ii}$_${ri}$lamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_${ri}$labad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need 6*n + 2*n space for storing balancing factors)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_${ri}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_${ri}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
! perform qz algorithm, computing schur vectors if desired
! (workspace: need n)
iwrk = itau
call stdlib${ii}$_${ri}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 50
end if
! sort eigenvalues alpha/beta if desired
! (workspace: need 4*n+16 )
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_${ri}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
50 continue
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$gges
#:endif
#:endfor
module subroutine stdlib${ii}$_cgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alpha, beta, &
!! CGGES computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the generalized complex Schur
!! form (S, T), and optionally left and/or right Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T. The leading
!! columns of VSL and VSR then form an unitary basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! CGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0, and even for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if S
!! and T are upper triangular and, in addition, the diagonal elements
!! of T are non-negative real numbers.
vsl, ldvsl, vsr, ldvsr, work,lwork, rwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_c) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, &
itau, iwrk, lwkmin, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(sp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -14_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
if( ilvsl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_cggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (complex workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_cgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
call stdlib${ii}$_chgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 30
end if
! sort eigenvalues alpha/beta if desired
! (workspace: none needed)
if( wantst ) then
! undo scaling on eigenvalues before selecting
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
call stdlib${ii}$_ctgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
30 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cgges
module subroutine stdlib${ii}$_zgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alpha, beta, &
!! ZGGES computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the generalized complex Schur
!! form (S, T), and optionally left and/or right Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T. The leading
!! columns of VSL and VSR then form an unitary basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! ZGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0, and even for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if S
!! and T are upper triangular and, in addition, the diagonal elements
!! of T are non-negative real numbers.
vsl, ldvsl, vsr, ldvsr, work,lwork, rwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_z) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, &
itau, iwrk, lwkmin, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(dp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -14_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
if( ilvsl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_zggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (complex workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
call stdlib${ii}$_zhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 30
end if
! sort eigenvalues alpha/beta if desired
! (workspace: none needed)
if( wantst ) then
! undo scaling on eigenvalues before selecting
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
call stdlib${ii}$_ztgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
30 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zgges
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$gges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alpha, beta, &
!! ZGGES: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the generalized complex Schur
!! form (S, T), and optionally left and/or right Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T. The leading
!! columns of VSL and VSR then form an unitary basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! ZGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0, and even for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if S
!! and T are upper triangular and, in addition, the diagonal elements
!! of T are non-negative real numbers.
vsl, ldvsl, vsr, ldvsr, work,lwork, rwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_${ci}$) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, &
itau, iwrk, lwkmin, lwkopt
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(${ck}$) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -14_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
if( ilvsl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_${ci}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (complex workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_${ci}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
call stdlib${ii}$_${ci}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 30
end if
! sort eigenvalues alpha/beta if desired
! (workspace: none needed)
if( wantst ) then
! undo scaling on eigenvalues before selecting
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
call stdlib${ii}$_${ci}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
30 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$gges
#:endif
#:endfor
module subroutine stdlib${ii}$_sggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, &
!! SGGESX computes for a pair of N-by-N real nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T; computes
!! a reciprocal condition number for the average of the selected
!! eigenvalues (RCONDE); and computes a reciprocal condition number for
!! the right and left deflating subspaces corresponding to the selected
!! eigenvalues (RCONDV). The leading columns of VSL and VSR then form
!! an orthonormal basis for the corresponding left and right eigenspaces
!! (deflating subspaces).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or for both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphar, alphai, beta, vsl, ldvsl,vsr, ldvsr, rconde, rcondv, work, lwork, iwork,liwork, &
bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2_${ik}$), rcondv(2_${ik}$), vsl(&
ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_s) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, wantsb, &
wantse, wantsn, wantst, wantsv
integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, &
irows, itau, iwrk, liwmin, lwrk, maxwrk, minwrk
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, safmax, safmin, &
smlnum
! Local Arrays
real(sp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( wantsn ) then
ijob = 0_${ik}$
else if( wantse ) then
ijob = 1_${ik}$
else if( wantsv ) then
ijob = 2_${ik}$
else if( wantsb ) then
ijob = 4_${ik}$
end if
! test the input arguments
info = 0_${ik}$
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -5_${ik}$
else if( n<0_${ik}$ ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -16_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -18_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$) then
minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ )
maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ )
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ &
) )
if( ilvsl ) then
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n, 1_${ik}$, n, &
-1_${ik}$ ) )
end if
lwrk = maxwrk
if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ )
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
lwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = lwrk
if( wantsn .or. n==0_${ik}$ ) then
liwmin = 1_${ik}$
else
liwmin = n + 6_${ik}$
end if
iwork( 1_${ik}$ ) = liwmin
if( lwork<minwrk .and. .not.lquery ) then
info = -22_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -24_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGESX', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
safmin = stdlib${ii}$_slamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_slabad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need 6*n + 2*n for permutation parameters)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (workspace: need n)
iwrk = itau
call stdlib${ii}$_shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 50
end if
! sort eigenvalues alpha/beta and compute the reciprocal of
! condition number(s)
! (workspace: if ijob >= 1, need max( 8*(n+1), 2*sdim*(n-sdim) )
! otherwise, need 8*(n+1) )
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
! reorder eigenvalues, transform generalized schur vectors, and
! compute reciprocal condition numbers
call stdlib${ii}$_stgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pl, pr, dif, work( iwrk ), lwork-iwrk+1,iwork, &
liwork, ierr )
if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( ierr==-22_${ik}$ ) then
! not enough real workspace
info = -22_${ik}$
else
if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then
rconde( 1_${ik}$ ) = pl
rconde( 2_${ik}$ ) = pr
end if
if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then
rcondv( 1_${ik}$ ) = dif( 1_${ik}$ )
rcondv( 2_${ik}$ ) = dif( 2_${ik}$ )
end if
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
end if
! apply permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ).or. ( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
50 continue
work( 1_${ik}$ ) = maxwrk
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_sggesx
module subroutine stdlib${ii}$_dggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, &
!! DGGESX computes for a pair of N-by-N real nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T; computes
!! a reciprocal condition number for the average of the selected
!! eigenvalues (RCONDE); and computes a reciprocal condition number for
!! the right and left deflating subspaces corresponding to the selected
!! eigenvalues (RCONDV). The leading columns of VSL and VSR then form
!! an orthonormal basis for the corresponding left and right eigenspaces
!! (deflating subspaces).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or for both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphar, alphai, beta, vsl, ldvsl,vsr, ldvsr, rconde, rcondv, work, lwork, iwork,liwork, &
bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2_${ik}$), rcondv(2_${ik}$), vsl(&
ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_d) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, wantsb, &
wantse, wantsn, wantst, wantsv
integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, &
irows, itau, iwrk, liwmin, lwrk, maxwrk, minwrk
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, safmax, safmin, &
smlnum
! Local Arrays
real(dp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( wantsn ) then
ijob = 0_${ik}$
else if( wantse ) then
ijob = 1_${ik}$
else if( wantsv ) then
ijob = 2_${ik}$
else if( wantsb ) then
ijob = 4_${ik}$
end if
! test the input arguments
info = 0_${ik}$
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -5_${ik}$
else if( n<0_${ik}$ ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -16_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -18_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$) then
minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ )
maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ )
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ &
) )
if( ilvsl ) then
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, &
-1_${ik}$ ) )
end if
lwrk = maxwrk
if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ )
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
lwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = lwrk
if( wantsn .or. n==0_${ik}$ ) then
liwmin = 1_${ik}$
else
liwmin = n + 6_${ik}$
end if
iwork( 1_${ik}$ ) = liwmin
if( lwork<minwrk .and. .not.lquery ) then
info = -22_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -24_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGESX', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
safmin = stdlib${ii}$_dlamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_dlabad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need 6*n + 2*n for permutation parameters)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_dggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_dgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (workspace: need n)
iwrk = itau
call stdlib${ii}$_dhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 60
end if
! sort eigenvalues alpha/beta and compute the reciprocal of
! condition number(s)
! (workspace: if ijob >= 1, need max( 8*(n+1), 2*sdim*(n-sdim) )
! otherwise, need 8*(n+1) )
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
! reorder eigenvalues, transform generalized schur vectors, and
! compute reciprocal condition numbers
call stdlib${ii}$_dtgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pl, pr, dif, work( iwrk ), lwork-iwrk+1,iwork, &
liwork, ierr )
if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( ierr==-22_${ik}$ ) then
! not enough real workspace
info = -22_${ik}$
else
if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then
rconde( 1_${ik}$ ) = pl
rconde( 2_${ik}$ ) = pr
end if
if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then
rcondv( 1_${ik}$ ) = dif( 1_${ik}$ )
rcondv( 2_${ik}$ ) = dif( 2_${ik}$ )
end if
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
end if
! apply permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
60 continue
work( 1_${ik}$ ) = maxwrk
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dggesx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$ggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, &
!! DGGESX: computes for a pair of N-by-N real nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T; computes
!! a reciprocal condition number for the average of the selected
!! eigenvalues (RCONDE); and computes a reciprocal condition number for
!! the right and left deflating subspaces corresponding to the selected
!! eigenvalues (RCONDV). The leading columns of VSL and VSR then form
!! an orthonormal basis for the corresponding left and right eigenspaces
!! (deflating subspaces).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or for both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphar, alphai, beta, vsl, ldvsl,vsr, ldvsr, rconde, rcondv, work, lwork, iwork,liwork, &
bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2_${ik}$), rcondv(2_${ik}$), vsl(&
ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_${ri}$) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, wantsb, &
wantse, wantsn, wantst, wantsv
integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, &
irows, itau, iwrk, liwmin, lwrk, maxwrk, minwrk
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, safmax, safmin, &
smlnum
! Local Arrays
real(${rk}$) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( wantsn ) then
ijob = 0_${ik}$
else if( wantse ) then
ijob = 1_${ik}$
else if( wantsv ) then
ijob = 2_${ik}$
else if( wantsb ) then
ijob = 4_${ik}$
end if
! test the input arguments
info = 0_${ik}$
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -5_${ik}$
else if( n<0_${ik}$ ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -16_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -18_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$) then
minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ )
maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ )
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ &
) )
if( ilvsl ) then
maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, &
-1_${ik}$ ) )
end if
lwrk = maxwrk
if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ )
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
lwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = lwrk
if( wantsn .or. n==0_${ik}$ ) then
liwmin = 1_${ik}$
else
liwmin = n + 6_${ik}$
end if
iwork( 1_${ik}$ ) = liwmin
if( lwork<minwrk .and. .not.lquery ) then
info = -22_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -24_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGESX', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
safmin = stdlib${ii}$_${ri}$lamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_${ri}$labad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need 6*n + 2*n for permutation parameters)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_${ri}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_${ri}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (workspace: need n)
iwrk = itau
call stdlib${ii}$_${ri}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 60
end if
! sort eigenvalues alpha/beta and compute the reciprocal of
! condition number(s)
! (workspace: if ijob >= 1, need max( 8*(n+1), 2*sdim*(n-sdim) )
! otherwise, need 8*(n+1) )
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
! reorder eigenvalues, transform generalized schur vectors, and
! compute reciprocal condition numbers
call stdlib${ii}$_${ri}$tgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pl, pr, dif, work( iwrk ), lwork-iwrk+1,iwork, &
liwork, ierr )
if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( ierr==-22_${ik}$ ) then
! not enough real workspace
info = -22_${ik}$
else
if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then
rconde( 1_${ik}$ ) = pl
rconde( 2_${ik}$ ) = pr
end if
if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then
rcondv( 1_${ik}$ ) = dif( 1_${ik}$ )
rcondv( 2_${ik}$ ) = dif( 2_${ik}$ )
end if
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
end if
! apply permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
60 continue
work( 1_${ik}$ ) = maxwrk
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$ggesx
#:endif
#:endfor
module subroutine stdlib${ii}$_cggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,&
!! CGGESX computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the complex Schur form (S,T),
!! and, optionally, the left and/or right matrices of Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T; computes
!! a reciprocal condition number for the average of the selected
!! eigenvalues (RCONDE); and computes a reciprocal condition number for
!! the right and left deflating subspaces corresponding to the selected
!! eigenvalues (RCONDV). The leading columns of VSL and VSR then form
!! an orthonormal basis for the corresponding left and right eigenspaces
!! (deflating subspaces).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if T is
!! upper triangular with non-negative diagonal and S is upper
!! triangular.
beta, vsl, ldvsl, vsr,ldvsr, rconde, rcondv, work, lwork, rwork,iwork, liwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: rconde(2_${ik}$), rcondv(2_${ik}$), rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_c) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantsb, wantse, &
wantsn, wantst, wantsv
integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, &
irwrk, itau, iwrk, liwmin, lwrk, maxwrk, minwrk
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, smlnum
! Local Arrays
real(sp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( wantsn ) then
ijob = 0_${ik}$
else if( wantse ) then
ijob = 1_${ik}$
else if( wantsv ) then
ijob = 2_${ik}$
else if( wantsb ) then
ijob = 4_${ik}$
end if
! test the input arguments
info = 0_${ik}$
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -5_${ik}$
else if( n<0_${ik}$ ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$) then
minwrk = 2_${ik}$*n
maxwrk = n*(1_${ik}$ + stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
if( ilvsl ) then
maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) &
)
end if
lwrk = maxwrk
if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ )
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
lwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = lwrk
if( wantsn .or. n==0_${ik}$ ) then
liwmin = 1_${ik}$
else
liwmin = n + 2_${ik}$
end if
iwork( 1_${ik}$ ) = liwmin
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
else if( liwork<liwmin .and. .not.lquery) then
info = -24_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGESX', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_cggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (complex workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_cgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
call stdlib${ii}$_chgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 40
end if
! sort eigenvalues alpha/beta and compute the reciprocal of
! condition number(s)
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
! reorder eigenvalues, transform generalized schur vectors, and
! compute reciprocal condition numbers
! (complex workspace: if ijob >= 1, need max(1, 2*sdim*(n-sdim))
! otherwise, need 1 )
call stdlib${ii}$_ctgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pl, pr,dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,ierr &
)
if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( ierr==-21_${ik}$ ) then
! not enough complex workspace
info = -21_${ik}$
else
if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then
rconde( 1_${ik}$ ) = pl
rconde( 2_${ik}$ ) = pr
end if
if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then
rcondv( 1_${ik}$ ) = dif( 1_${ik}$ )
rcondv( 2_${ik}$ ) = dif( 2_${ik}$ )
end if
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
end if
! apply permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
40 continue
work( 1_${ik}$ ) = maxwrk
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_cggesx
module subroutine stdlib${ii}$_zggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,&
!! ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the complex Schur form (S,T),
!! and, optionally, the left and/or right matrices of Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T; computes
!! a reciprocal condition number for the average of the selected
!! eigenvalues (RCONDE); and computes a reciprocal condition number for
!! the right and left deflating subspaces corresponding to the selected
!! eigenvalues (RCONDV). The leading columns of VSL and VSR then form
!! an orthonormal basis for the corresponding left and right eigenspaces
!! (deflating subspaces).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if T is
!! upper triangular with non-negative diagonal and S is upper
!! triangular.
beta, vsl, ldvsl, vsr,ldvsr, rconde, rcondv, work, lwork, rwork,iwork, liwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: rconde(2_${ik}$), rcondv(2_${ik}$), rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_z) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantsb, wantse, &
wantsn, wantst, wantsv
integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, &
irwrk, itau, iwrk, liwmin, lwrk, maxwrk, minwrk
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, smlnum
! Local Arrays
real(dp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( wantsn ) then
ijob = 0_${ik}$
else if( wantse ) then
ijob = 1_${ik}$
else if( wantsv ) then
ijob = 2_${ik}$
else if( wantsb ) then
ijob = 4_${ik}$
end if
! test the input arguments
info = 0_${ik}$
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -5_${ik}$
else if( n<0_${ik}$ ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$) then
minwrk = 2_${ik}$*n
maxwrk = n*(1_${ik}$ + stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
if( ilvsl ) then
maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) &
)
end if
lwrk = maxwrk
if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ )
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
lwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = lwrk
if( wantsn .or. n==0_${ik}$ ) then
liwmin = 1_${ik}$
else
liwmin = n + 2_${ik}$
end if
iwork( 1_${ik}$ ) = liwmin
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
else if( liwork<liwmin .and. .not.lquery) then
info = -24_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGESX', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_zggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (complex workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
call stdlib${ii}$_zhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 40
end if
! sort eigenvalues alpha/beta and compute the reciprocal of
! condition number(s)
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
! reorder eigenvalues, transform generalized schur vectors, and
! compute reciprocal condition numbers
! (complex workspace: if ijob >= 1, need max(1, 2*sdim*(n-sdim))
! otherwise, need 1 )
call stdlib${ii}$_ztgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pl, pr,dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,ierr &
)
if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( ierr==-21_${ik}$ ) then
! not enough complex workspace
info = -21_${ik}$
else
if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then
rconde( 1_${ik}$ ) = pl
rconde( 2_${ik}$ ) = pr
end if
if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then
rcondv( 1_${ik}$ ) = dif( 1_${ik}$ )
rcondv( 2_${ik}$ ) = dif( 2_${ik}$ )
end if
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
end if
! apply permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
40 continue
work( 1_${ik}$ ) = maxwrk
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_zggesx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$ggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,&
!! ZGGESX: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the complex Schur form (S,T),
!! and, optionally, the left and/or right matrices of Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T; computes
!! a reciprocal condition number for the average of the selected
!! eigenvalues (RCONDE); and computes a reciprocal condition number for
!! the right and left deflating subspaces corresponding to the selected
!! eigenvalues (RCONDV). The leading columns of VSL and VSR then form
!! an orthonormal basis for the corresponding left and right eigenspaces
!! (deflating subspaces).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if T is
!! upper triangular with non-negative diagonal and S is upper
!! triangular.
beta, vsl, ldvsl, vsr,ldvsr, rconde, rcondv, work, lwork, rwork,iwork, liwork, bwork, info )
! -- lapack driver 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) :: jobvsl, jobvsr, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: rconde(2_${ik}$), rcondv(2_${ik}$), rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_${ci}$) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantsb, wantse, &
wantsn, wantst, wantsv
integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, &
irwrk, itau, iwrk, liwmin, lwrk, maxwrk, minwrk
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, smlnum
! Local Arrays
real(${ck}$) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( wantsn ) then
ijob = 0_${ik}$
else if( wantse ) then
ijob = 1_${ik}$
else if( wantsv ) then
ijob = 2_${ik}$
else if( wantsb ) then
ijob = 4_${ik}$
end if
! test the input arguments
info = 0_${ik}$
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -5_${ik}$
else if( n<0_${ik}$ ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.)
if( info==0_${ik}$ ) then
if( n>0_${ik}$) then
minwrk = 2_${ik}$*n
maxwrk = n*(1_${ik}$ + stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
if( ilvsl ) then
maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) &
)
end if
lwrk = maxwrk
if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ )
else
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
lwrk = 1_${ik}$
end if
work( 1_${ik}$ ) = lwrk
if( wantsn .or. n==0_${ik}$ ) then
liwmin = 1_${ik}$
else
liwmin = n + 2_${ik}$
end if
iwork( 1_${ik}$ ) = liwmin
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
else if( liwork<liwmin .and. .not.lquery) then
info = -24_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGESX', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_${ci}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
! (complex workspace: need n, prefer n*nb)
if( ilvsl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
! (workspace: none needed)
call stdlib${ii}$_${ci}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
call stdlib${ii}$_${ci}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 40
end if
! sort eigenvalues alpha/beta and compute the reciprocal of
! condition number(s)
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
! reorder eigenvalues, transform generalized schur vectors, and
! compute reciprocal condition numbers
! (complex workspace: if ijob >= 1, need max(1, 2*sdim*(n-sdim))
! otherwise, need 1 )
call stdlib${ii}$_${ci}$tgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pl, pr,dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,ierr &
)
if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( ierr==-21_${ik}$ ) then
! not enough complex workspace
info = -21_${ik}$
else
if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then
rconde( 1_${ik}$ ) = pl
rconde( 2_${ik}$ ) = pr
end if
if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then
rcondv( 1_${ik}$ ) = dif( 1_${ik}$ )
rcondv( 2_${ik}$ ) = dif( 2_${ik}$ )
end if
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
end if
! apply permutation to vsl and vsr
! (workspace: none needed)
if( ilvsl )call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) then
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
sdim = 0_${ik}$
do i = 1, n
cursl = selctg( alpha( i ), beta( i ) )
if( cursl )sdim = sdim + 1_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
lastsl = cursl
end do
end if
40 continue
work( 1_${ik}$ ) = maxwrk
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ci}$ggesx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgebal( job, n, a, lda, ilo, ihi, scale, info )
!! SGEBAL balances a general real matrix A. This involves, first,
!! permuting A by a similarity transformation to isolate eigenvalues
!! in the first 1 to ILO-1 and last IHI+1 to N elements on the
!! diagonal; and second, applying a diagonal similarity transformation
!! to rows and columns ILO to IHI to make the rows and columns as
!! close in norm as possible. Both steps are optional.
!! Balancing may reduce the 1-norm of the matrix, and improve the
!! accuracy of the computed eigenvalues and/or eigenvectors.
! -- 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) :: job
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: scale(*)
! =====================================================================
! Parameters
real(sp), parameter :: sclfac = 2.0e+0_sp
real(sp), parameter :: factor = 0.95e+0_sp
! Local Scalars
logical(lk) :: noconv
integer(${ik}$) :: i, ica, iexc, ira, j, k, l, m
real(sp) :: c, ca, f, g, r, ra, s, sfmax1, sfmax2, sfmin1, sfmin2
! Intrinsic Functions
! test the input parameters
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) 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( 'SGEBAL', -info )
return
end if
k = 1_${ik}$
l = n
if( n==0 )go to 210
if( stdlib_lsame( job, 'N' ) ) then
do i = 1, n
scale( i ) = one
end do
go to 210
end if
if( stdlib_lsame( job, 'S' ) )go to 120
! permutation to isolate eigenvalues if possible
go to 50
! row and column exchange.
20 continue
scale( m ) = j
if( j==m )go to 30
call stdlib${ii}$_sswap( l, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, m ), 1_${ik}$ )
call stdlib${ii}$_sswap( n-k+1, a( j, k ), lda, a( m, k ), lda )
30 continue
go to ( 40, 80 )iexc
! search for rows isolating an eigenvalue and push them down.
40 continue
if( l==1 )go to 210
l = l - 1_${ik}$
50 continue
loop_70: do j = l, 1, -1
loop_60: do i = 1, l
if( i==j )cycle loop_60
if( a( j, i )/=zero )cycle loop_70
end do loop_60
m = l
iexc = 1_${ik}$
go to 20
end do loop_70
go to 90
! search for columns isolating an eigenvalue and push them left.
80 continue
k = k + 1_${ik}$
90 continue
loop_110: do j = k, l
loop_100: do i = k, l
if( i==j )cycle loop_100
if( a( i, j )/=zero )cycle loop_110
end do loop_100
m = k
iexc = 2_${ik}$
go to 20
end do loop_110
120 continue
do i = k, l
scale( i ) = one
end do
if( stdlib_lsame( job, 'P' ) )go to 210
! balance the submatrix in rows k to l.
! iterative loop for norm reduction
sfmin1 = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'P' )
sfmax1 = one / sfmin1
sfmin2 = sfmin1*sclfac
sfmax2 = one / sfmin2
140 continue
noconv = .false.
loop_200: do i = k, l
c = stdlib${ii}$_snrm2( l-k+1, a( k, i ), 1_${ik}$ )
r = stdlib${ii}$_snrm2( l-k+1, a( i, k ), lda )
ica = stdlib${ii}$_isamax( l, a( 1_${ik}$, i ), 1_${ik}$ )
ca = abs( a( ica, i ) )
ira = stdlib${ii}$_isamax( n-k+1, a( i, k ), lda )
ra = abs( a( i, ira+k-1 ) )
! guard against zero c or r due to underflow.
if( c==zero .or. r==zero )cycle loop_200
g = r / sclfac
f = one
s = c + r
160 continue
if( c>=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170
f = f*sclfac
c = c*sclfac
ca = ca*sclfac
r = r / sclfac
g = g / sclfac
ra = ra / sclfac
go to 160
170 continue
g = c / sclfac
180 continue
if( g<r .or. max( r, ra )>=sfmax2 .or.min( f, c, g, ca )<=sfmin2 )go to 190
if( stdlib${ii}$_sisnan( c+f+ca+r+g+ra ) ) then
! exit if nan to avoid infinite loop
info = -3_${ik}$
call stdlib${ii}$_xerbla( 'SGEBAL', -info )
return
end if
f = f / sclfac
c = c / sclfac
g = g / sclfac
ca = ca / sclfac
r = r*sclfac
ra = ra*sclfac
go to 180
! now balance.
190 continue
if( ( c+r )>=factor*s )cycle loop_200
if( f<one .and. scale( i )<one ) then
if( f*scale( i )<=sfmin1 )cycle loop_200
end if
if( f>one .and. scale( i )>one ) then
if( scale( i )>=sfmax1 / f )cycle loop_200
end if
g = one / f
scale( i ) = scale( i )*f
noconv = .true.
call stdlib${ii}$_sscal( n-k+1, g, a( i, k ), lda )
call stdlib${ii}$_sscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ )
end do loop_200
if( noconv )go to 140
210 continue
ilo = k
ihi = l
return
end subroutine stdlib${ii}$_sgebal
pure module subroutine stdlib${ii}$_dgebal( job, n, a, lda, ilo, ihi, scale, info )
!! DGEBAL balances a general real matrix A. This involves, first,
!! permuting A by a similarity transformation to isolate eigenvalues
!! in the first 1 to ILO-1 and last IHI+1 to N elements on the
!! diagonal; and second, applying a diagonal similarity transformation
!! to rows and columns ILO to IHI to make the rows and columns as
!! close in norm as possible. Both steps are optional.
!! Balancing may reduce the 1-norm of the matrix, and improve the
!! accuracy of the computed eigenvalues and/or eigenvectors.
! -- 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) :: job
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: scale(*)
! =====================================================================
! Parameters
real(dp), parameter :: sclfac = 2.0e+0_dp
real(dp), parameter :: factor = 0.95e+0_dp
! Local Scalars
logical(lk) :: noconv
integer(${ik}$) :: i, ica, iexc, ira, j, k, l, m
real(dp) :: c, ca, f, g, r, ra, s, sfmax1, sfmax2, sfmin1, sfmin2
! Intrinsic Functions
! test the input parameters
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) 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( 'DGEBAL', -info )
return
end if
k = 1_${ik}$
l = n
if( n==0 )go to 210
if( stdlib_lsame( job, 'N' ) ) then
do i = 1, n
scale( i ) = one
end do
go to 210
end if
if( stdlib_lsame( job, 'S' ) )go to 120
! permutation to isolate eigenvalues if possible
go to 50
! row and column exchange.
20 continue
scale( m ) = j
if( j==m )go to 30
call stdlib${ii}$_dswap( l, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, m ), 1_${ik}$ )
call stdlib${ii}$_dswap( n-k+1, a( j, k ), lda, a( m, k ), lda )
30 continue
go to ( 40, 80 )iexc
! search for rows isolating an eigenvalue and push them down.
40 continue
if( l==1 )go to 210
l = l - 1_${ik}$
50 continue
loop_70: do j = l, 1, -1
loop_60: do i = 1, l
if( i==j )cycle loop_60
if( a( j, i )/=zero )cycle loop_70
end do loop_60
m = l
iexc = 1_${ik}$
go to 20
end do loop_70
go to 90
! search for columns isolating an eigenvalue and push them left.
80 continue
k = k + 1_${ik}$
90 continue
loop_110: do j = k, l
loop_100: do i = k, l
if( i==j )cycle loop_100
if( a( i, j )/=zero )cycle loop_110
end do loop_100
m = k
iexc = 2_${ik}$
go to 20
end do loop_110
120 continue
do i = k, l
scale( i ) = one
end do
if( stdlib_lsame( job, 'P' ) )go to 210
! balance the submatrix in rows k to l.
! iterative loop for norm reduction
sfmin1 = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'P' )
sfmax1 = one / sfmin1
sfmin2 = sfmin1*sclfac
sfmax2 = one / sfmin2
140 continue
noconv = .false.
loop_200: do i = k, l
c = stdlib${ii}$_dnrm2( l-k+1, a( k, i ), 1_${ik}$ )
r = stdlib${ii}$_dnrm2( l-k+1, a( i, k ), lda )
ica = stdlib${ii}$_idamax( l, a( 1_${ik}$, i ), 1_${ik}$ )
ca = abs( a( ica, i ) )
ira = stdlib${ii}$_idamax( n-k+1, a( i, k ), lda )
ra = abs( a( i, ira+k-1 ) )
! guard against zero c or r due to underflow.
if( c==zero .or. r==zero )cycle loop_200
g = r / sclfac
f = one
s = c + r
160 continue
if( c>=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170
if( stdlib${ii}$_disnan( c+f+ca+r+g+ra ) ) then
! exit if nan to avoid infinite loop
info = -3_${ik}$
call stdlib${ii}$_xerbla( 'DGEBAL', -info )
return
end if
f = f*sclfac
c = c*sclfac
ca = ca*sclfac
r = r / sclfac
g = g / sclfac
ra = ra / sclfac
go to 160
170 continue
g = c / sclfac
180 continue
if( g<r .or. max( r, ra )>=sfmax2 .or.min( f, c, g, ca )<=sfmin2 )go to 190
f = f / sclfac
c = c / sclfac
g = g / sclfac
ca = ca / sclfac
r = r*sclfac
ra = ra*sclfac
go to 180
! now balance.
190 continue
if( ( c+r )>=factor*s )cycle loop_200
if( f<one .and. scale( i )<one ) then
if( f*scale( i )<=sfmin1 )cycle loop_200
end if
if( f>one .and. scale( i )>one ) then
if( scale( i )>=sfmax1 / f )cycle loop_200
end if
g = one / f
scale( i ) = scale( i )*f
noconv = .true.
call stdlib${ii}$_dscal( n-k+1, g, a( i, k ), lda )
call stdlib${ii}$_dscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ )
end do loop_200
if( noconv )go to 140
210 continue
ilo = k
ihi = l
return
end subroutine stdlib${ii}$_dgebal
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gebal( job, n, a, lda, ilo, ihi, scale, info )
!! DGEBAL: balances a general real matrix A. This involves, first,
!! permuting A by a similarity transformation to isolate eigenvalues
!! in the first 1 to ILO-1 and last IHI+1 to N elements on the
!! diagonal; and second, applying a diagonal similarity transformation
!! to rows and columns ILO to IHI to make the rows and columns as
!! close in norm as possible. Both steps are optional.
!! Balancing may reduce the 1-norm of the matrix, and improve the
!! accuracy of the computed eigenvalues and/or eigenvectors.
! -- 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) :: job
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: scale(*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: sclfac = 2.0e+0_${rk}$
real(${rk}$), parameter :: factor = 0.95e+0_${rk}$
! Local Scalars
logical(lk) :: noconv
integer(${ik}$) :: i, ica, iexc, ira, j, k, l, m
real(${rk}$) :: c, ca, f, g, r, ra, s, sfmax1, sfmax2, sfmin1, sfmin2
! Intrinsic Functions
! test the input parameters
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) 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( 'DGEBAL', -info )
return
end if
k = 1_${ik}$
l = n
if( n==0 )go to 210
if( stdlib_lsame( job, 'N' ) ) then
do i = 1, n
scale( i ) = one
end do
go to 210
end if
if( stdlib_lsame( job, 'S' ) )go to 120
! permutation to isolate eigenvalues if possible
go to 50
! row and column exchange.
20 continue
scale( m ) = j
if( j==m )go to 30
call stdlib${ii}$_${ri}$swap( l, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, m ), 1_${ik}$ )
call stdlib${ii}$_${ri}$swap( n-k+1, a( j, k ), lda, a( m, k ), lda )
30 continue
go to ( 40, 80 )iexc
! search for rows isolating an eigenvalue and push them down.
40 continue
if( l==1 )go to 210
l = l - 1_${ik}$
50 continue
loop_70: do j = l, 1, -1
loop_60: do i = 1, l
if( i==j )cycle loop_60
if( a( j, i )/=zero )cycle loop_70
end do loop_60
m = l
iexc = 1_${ik}$
go to 20
end do loop_70
go to 90
! search for columns isolating an eigenvalue and push them left.
80 continue
k = k + 1_${ik}$
90 continue
loop_110: do j = k, l
loop_100: do i = k, l
if( i==j )cycle loop_100
if( a( i, j )/=zero )cycle loop_110
end do loop_100
m = k
iexc = 2_${ik}$
go to 20
end do loop_110
120 continue
do i = k, l
scale( i ) = one
end do
if( stdlib_lsame( job, 'P' ) )go to 210
! balance the submatrix in rows k to l.
! iterative loop for norm reduction
sfmin1 = stdlib${ii}$_${ri}$lamch( 'S' ) / stdlib${ii}$_${ri}$lamch( 'P' )
sfmax1 = one / sfmin1
sfmin2 = sfmin1*sclfac
sfmax2 = one / sfmin2
140 continue
noconv = .false.
loop_200: do i = k, l
c = stdlib${ii}$_${ri}$nrm2( l-k+1, a( k, i ), 1_${ik}$ )
r = stdlib${ii}$_${ri}$nrm2( l-k+1, a( i, k ), lda )
ica = stdlib${ii}$_i${ri}$amax( l, a( 1_${ik}$, i ), 1_${ik}$ )
ca = abs( a( ica, i ) )
ira = stdlib${ii}$_i${ri}$amax( n-k+1, a( i, k ), lda )
ra = abs( a( i, ira+k-1 ) )
! guard against zero c or r due to underflow.
if( c==zero .or. r==zero )cycle loop_200
g = r / sclfac
f = one
s = c + r
160 continue
if( c>=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170
if( stdlib${ii}$_${ri}$isnan( c+f+ca+r+g+ra ) ) then
! exit if nan to avoid infinite loop
info = -3_${ik}$
call stdlib${ii}$_xerbla( 'DGEBAL', -info )
return
end if
f = f*sclfac
c = c*sclfac
ca = ca*sclfac
r = r / sclfac
g = g / sclfac
ra = ra / sclfac
go to 160
170 continue
g = c / sclfac
180 continue
if( g<r .or. max( r, ra )>=sfmax2 .or.min( f, c, g, ca )<=sfmin2 )go to 190
f = f / sclfac
c = c / sclfac
g = g / sclfac
ca = ca / sclfac
r = r*sclfac
ra = ra*sclfac
go to 180
! now balance.
190 continue
if( ( c+r )>=factor*s )cycle loop_200
if( f<one .and. scale( i )<one ) then
if( f*scale( i )<=sfmin1 )cycle loop_200
end if
if( f>one .and. scale( i )>one ) then
if( scale( i )>=sfmax1 / f )cycle loop_200
end if
g = one / f
scale( i ) = scale( i )*f
noconv = .true.
call stdlib${ii}$_${ri}$scal( n-k+1, g, a( i, k ), lda )
call stdlib${ii}$_${ri}$scal( l, f, a( 1_${ik}$, i ), 1_${ik}$ )
end do loop_200
if( noconv )go to 140
210 continue
ilo = k
ihi = l
return
end subroutine stdlib${ii}$_${ri}$gebal
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgebal( job, n, a, lda, ilo, ihi, scale, info )
!! CGEBAL balances a general complex matrix A. This involves, first,
!! permuting A by a similarity transformation to isolate eigenvalues
!! in the first 1 to ILO-1 and last IHI+1 to N elements on the
!! diagonal; and second, applying a diagonal similarity transformation
!! to rows and columns ILO to IHI to make the rows and columns as
!! close in norm as possible. Both steps are optional.
!! Balancing may reduce the 1-norm of the matrix, and improve the
!! accuracy of the computed eigenvalues and/or eigenvectors.
! -- 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) :: job
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(out) :: scale(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(sp), parameter :: sclfac = 2.0e+0_sp
real(sp), parameter :: factor = 0.95e+0_sp
! Local Scalars
logical(lk) :: noconv
integer(${ik}$) :: i, ica, iexc, ira, j, k, l, m
real(sp) :: c, ca, f, g, r, ra, s, sfmax1, sfmax2, sfmin1, sfmin2
! Intrinsic Functions
! test the input parameters
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) 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( 'CGEBAL', -info )
return
end if
k = 1_${ik}$
l = n
if( n==0 )go to 210
if( stdlib_lsame( job, 'N' ) ) then
do i = 1, n
scale( i ) = one
end do
go to 210
end if
if( stdlib_lsame( job, 'S' ) )go to 120
! permutation to isolate eigenvalues if possible
go to 50
! row and column exchange.
20 continue
scale( m ) = j
if( j==m )go to 30
call stdlib${ii}$_cswap( l, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, m ), 1_${ik}$ )
call stdlib${ii}$_cswap( n-k+1, a( j, k ), lda, a( m, k ), lda )
30 continue
go to ( 40, 80 )iexc
! search for rows isolating an eigenvalue and push them down.
40 continue
if( l==1 )go to 210
l = l - 1_${ik}$
50 continue
loop_70: do j = l, 1, -1
loop_60: do i = 1, l
if( i==j )cycle loop_60
if( real( a( j, i ),KIND=sp)/=zero .or. aimag( a( j, i ) )/=zero )cycle &
loop_70
end do loop_60
m = l
iexc = 1_${ik}$
go to 20
end do loop_70
go to 90
! search for columns isolating an eigenvalue and push them left.
80 continue
k = k + 1_${ik}$
90 continue
loop_110: do j = k, l
loop_100: do i = k, l
if( i==j )cycle loop_100
if( real( a( i, j ),KIND=sp)/=zero .or. aimag( a( i, j ) )/=zero )cycle &
loop_110
end do loop_100
m = k
iexc = 2_${ik}$
go to 20
end do loop_110
120 continue
do i = k, l
scale( i ) = one
end do
if( stdlib_lsame( job, 'P' ) )go to 210
! balance the submatrix in rows k to l.
! iterative loop for norm reduction
sfmin1 = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'P' )
sfmax1 = one / sfmin1
sfmin2 = sfmin1*sclfac
sfmax2 = one / sfmin2
140 continue
noconv = .false.
loop_200: do i = k, l
c = stdlib${ii}$_scnrm2( l-k+1, a( k, i ), 1_${ik}$ )
r = stdlib${ii}$_scnrm2( l-k+1, a( i , k ), lda )
ica = stdlib${ii}$_icamax( l, a( 1_${ik}$, i ), 1_${ik}$ )
ca = abs( a( ica, i ) )
ira = stdlib${ii}$_icamax( n-k+1, a( i, k ), lda )
ra = abs( a( i, ira+k-1 ) )
! guard against zero c or r due to underflow.
if( c==zero .or. r==zero )cycle loop_200
g = r / sclfac
f = one
s = c + r
160 continue
if( c>=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170
if( stdlib${ii}$_sisnan( c+f+ca+r+g+ra ) ) then
! exit if nan to avoid infinite loop
info = -3_${ik}$
call stdlib${ii}$_xerbla( 'CGEBAL', -info )
return
end if
f = f*sclfac
c = c*sclfac
ca = ca*sclfac
r = r / sclfac
g = g / sclfac
ra = ra / sclfac
go to 160
170 continue
g = c / sclfac
180 continue
if( g<r .or. max( r, ra )>=sfmax2 .or.min( f, c, g, ca )<=sfmin2 )go to 190
f = f / sclfac
c = c / sclfac
g = g / sclfac
ca = ca / sclfac
r = r*sclfac
ra = ra*sclfac
go to 180
! now balance.
190 continue
if( ( c+r )>=factor*s )cycle loop_200
if( f<one .and. scale( i )<one ) then
if( f*scale( i )<=sfmin1 )cycle loop_200
end if
if( f>one .and. scale( i )>one ) then
if( scale( i )>=sfmax1 / f )cycle loop_200
end if
g = one / f
scale( i ) = scale( i )*f
noconv = .true.
call stdlib${ii}$_csscal( n-k+1, g, a( i, k ), lda )
call stdlib${ii}$_csscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ )
end do loop_200
if( noconv )go to 140
210 continue
ilo = k
ihi = l
return
end subroutine stdlib${ii}$_cgebal
pure module subroutine stdlib${ii}$_zgebal( job, n, a, lda, ilo, ihi, scale, info )
!! ZGEBAL balances a general complex matrix A. This involves, first,
!! permuting A by a similarity transformation to isolate eigenvalues
!! in the first 1 to ILO-1 and last IHI+1 to N elements on the
!! diagonal; and second, applying a diagonal similarity transformation
!! to rows and columns ILO to IHI to make the rows and columns as
!! close in norm as possible. Both steps are optional.
!! Balancing may reduce the 1-norm of the matrix, and improve the
!! accuracy of the computed eigenvalues and/or eigenvectors.
! -- 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) :: job
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(out) :: scale(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(dp), parameter :: sclfac = 2.0e+0_dp
real(dp), parameter :: factor = 0.95e+0_dp
! Local Scalars
logical(lk) :: noconv
integer(${ik}$) :: i, ica, iexc, ira, j, k, l, m
real(dp) :: c, ca, f, g, r, ra, s, sfmax1, sfmax2, sfmin1, sfmin2
! Intrinsic Functions
! test the input parameters
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) 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( 'ZGEBAL', -info )
return
end if
k = 1_${ik}$
l = n
if( n==0 )go to 210
if( stdlib_lsame( job, 'N' ) ) then
do i = 1, n
scale( i ) = one
end do
go to 210
end if
if( stdlib_lsame( job, 'S' ) )go to 120
! permutation to isolate eigenvalues if possible
go to 50
! row and column exchange.
20 continue
scale( m ) = j
if( j==m )go to 30
call stdlib${ii}$_zswap( l, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, m ), 1_${ik}$ )
call stdlib${ii}$_zswap( n-k+1, a( j, k ), lda, a( m, k ), lda )
30 continue
go to ( 40, 80 )iexc
! search for rows isolating an eigenvalue and push them down.
40 continue
if( l==1 )go to 210
l = l - 1_${ik}$
50 continue
loop_70: do j = l, 1, -1
loop_60: do i = 1, l
if( i==j )cycle loop_60
if( real( a( j, i ),KIND=dp)/=zero .or. aimag( a( j, i ) )/=zero )cycle &
loop_70
end do loop_60
m = l
iexc = 1_${ik}$
go to 20
end do loop_70
go to 90
! search for columns isolating an eigenvalue and push them left.
80 continue
k = k + 1_${ik}$
90 continue
loop_110: do j = k, l
loop_100: do i = k, l
if( i==j )cycle loop_100
if( real( a( i, j ),KIND=dp)/=zero .or. aimag( a( i, j ) )/=zero )cycle &
loop_110
end do loop_100
m = k
iexc = 2_${ik}$
go to 20
end do loop_110
120 continue
do i = k, l
scale( i ) = one
end do
if( stdlib_lsame( job, 'P' ) )go to 210
! balance the submatrix in rows k to l.
! iterative loop for norm reduction
sfmin1 = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'P' )
sfmax1 = one / sfmin1
sfmin2 = sfmin1*sclfac
sfmax2 = one / sfmin2
140 continue
noconv = .false.
loop_200: do i = k, l
c = stdlib${ii}$_dznrm2( l-k+1, a( k, i ), 1_${ik}$ )
r = stdlib${ii}$_dznrm2( l-k+1, a( i, k ), lda )
ica = stdlib${ii}$_izamax( l, a( 1_${ik}$, i ), 1_${ik}$ )
ca = abs( a( ica, i ) )
ira = stdlib${ii}$_izamax( n-k+1, a( i, k ), lda )
ra = abs( a( i, ira+k-1 ) )
! guard against zero c or r due to underflow.
if( c==zero .or. r==zero )cycle loop_200
g = r / sclfac
f = one
s = c + r
160 continue
if( c>=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170
if( stdlib${ii}$_disnan( c+f+ca+r+g+ra ) ) then
! exit if nan to avoid infinite loop
info = -3_${ik}$
call stdlib${ii}$_xerbla( 'ZGEBAL', -info )
return
end if
f = f*sclfac
c = c*sclfac
ca = ca*sclfac
r = r / sclfac
g = g / sclfac
ra = ra / sclfac
go to 160
170 continue
g = c / sclfac
180 continue
if( g<r .or. max( r, ra )>=sfmax2 .or.min( f, c, g, ca )<=sfmin2 )go to 190
f = f / sclfac
c = c / sclfac
g = g / sclfac
ca = ca / sclfac
r = r*sclfac
ra = ra*sclfac
go to 180
! now balance.
190 continue
if( ( c+r )>=factor*s )cycle loop_200
if( f<one .and. scale( i )<one ) then
if( f*scale( i )<=sfmin1 )cycle loop_200
end if
if( f>one .and. scale( i )>one ) then
if( scale( i )>=sfmax1 / f )cycle loop_200
end if
g = one / f
scale( i ) = scale( i )*f
noconv = .true.
call stdlib${ii}$_zdscal( n-k+1, g, a( i, k ), lda )
call stdlib${ii}$_zdscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ )
end do loop_200
if( noconv )go to 140
210 continue
ilo = k
ihi = l
return
end subroutine stdlib${ii}$_zgebal
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gebal( job, n, a, lda, ilo, ihi, scale, info )
!! ZGEBAL: balances a general complex matrix A. This involves, first,
!! permuting A by a similarity transformation to isolate eigenvalues
!! in the first 1 to ILO-1 and last IHI+1 to N elements on the
!! diagonal; and second, applying a diagonal similarity transformation
!! to rows and columns ILO to IHI to make the rows and columns as
!! close in norm as possible. Both steps are optional.
!! Balancing may reduce the 1-norm of the matrix, and improve the
!! accuracy of the computed eigenvalues and/or eigenvectors.
! -- 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) :: job
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${ck}$), intent(out) :: scale(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: sclfac = 2.0e+0_${ck}$
real(${ck}$), parameter :: factor = 0.95e+0_${ck}$
! Local Scalars
logical(lk) :: noconv
integer(${ik}$) :: i, ica, iexc, ira, j, k, l, m
real(${ck}$) :: c, ca, f, g, r, ra, s, sfmax1, sfmax2, sfmin1, sfmin2
! Intrinsic Functions
! test the input parameters
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) 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( 'ZGEBAL', -info )
return
end if
k = 1_${ik}$
l = n
if( n==0 )go to 210
if( stdlib_lsame( job, 'N' ) ) then
do i = 1, n
scale( i ) = one
end do
go to 210
end if
if( stdlib_lsame( job, 'S' ) )go to 120
! permutation to isolate eigenvalues if possible
go to 50
! row and column exchange.
20 continue
scale( m ) = j
if( j==m )go to 30
call stdlib${ii}$_${ci}$swap( l, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, m ), 1_${ik}$ )
call stdlib${ii}$_${ci}$swap( n-k+1, a( j, k ), lda, a( m, k ), lda )
30 continue
go to ( 40, 80 )iexc
! search for rows isolating an eigenvalue and push them down.
40 continue
if( l==1 )go to 210
l = l - 1_${ik}$
50 continue
loop_70: do j = l, 1, -1
loop_60: do i = 1, l
if( i==j )cycle loop_60
if( real( a( j, i ),KIND=${ck}$)/=zero .or. aimag( a( j, i ) )/=zero )cycle &
loop_70
end do loop_60
m = l
iexc = 1_${ik}$
go to 20
end do loop_70
go to 90
! search for columns isolating an eigenvalue and push them left.
80 continue
k = k + 1_${ik}$
90 continue
loop_110: do j = k, l
loop_100: do i = k, l
if( i==j )cycle loop_100
if( real( a( i, j ),KIND=${ck}$)/=zero .or. aimag( a( i, j ) )/=zero )cycle &
loop_110
end do loop_100
m = k
iexc = 2_${ik}$
go to 20
end do loop_110
120 continue
do i = k, l
scale( i ) = one
end do
if( stdlib_lsame( job, 'P' ) )go to 210
! balance the submatrix in rows k to l.
! iterative loop for norm reduction
sfmin1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
sfmax1 = one / sfmin1
sfmin2 = sfmin1*sclfac
sfmax2 = one / sfmin2
140 continue
noconv = .false.
loop_200: do i = k, l
c = stdlib${ii}$_${c2ri(ci)}$znrm2( l-k+1, a( k, i ), 1_${ik}$ )
r = stdlib${ii}$_${c2ri(ci)}$znrm2( l-k+1, a( i, k ), lda )
ica = stdlib${ii}$_i${ci}$amax( l, a( 1_${ik}$, i ), 1_${ik}$ )
ca = abs( a( ica, i ) )
ira = stdlib${ii}$_i${ci}$amax( n-k+1, a( i, k ), lda )
ra = abs( a( i, ira+k-1 ) )
! guard against zero c or r due to underflow.
if( c==zero .or. r==zero )cycle loop_200
g = r / sclfac
f = one
s = c + r
160 continue
if( c>=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170
if( stdlib${ii}$_${c2ri(ci)}$isnan( c+f+ca+r+g+ra ) ) then
! exit if nan to avoid infinite loop
info = -3_${ik}$
call stdlib${ii}$_xerbla( 'ZGEBAL', -info )
return
end if
f = f*sclfac
c = c*sclfac
ca = ca*sclfac
r = r / sclfac
g = g / sclfac
ra = ra / sclfac
go to 160
170 continue
g = c / sclfac
180 continue
if( g<r .or. max( r, ra )>=sfmax2 .or.min( f, c, g, ca )<=sfmin2 )go to 190
f = f / sclfac
c = c / sclfac
g = g / sclfac
ca = ca / sclfac
r = r*sclfac
ra = ra*sclfac
go to 180
! now balance.
190 continue
if( ( c+r )>=factor*s )cycle loop_200
if( f<one .and. scale( i )<one ) then
if( f*scale( i )<=sfmin1 )cycle loop_200
end if
if( f>one .and. scale( i )>one ) then
if( scale( i )>=sfmax1 / f )cycle loop_200
end if
g = one / f
scale( i ) = scale( i )*f
noconv = .true.
call stdlib${ii}$_${ci}$dscal( n-k+1, g, a( i, k ), lda )
call stdlib${ii}$_${ci}$dscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ )
end do loop_200
if( noconv )go to 140
210 continue
ilo = k
ihi = l
return
end subroutine stdlib${ii}$_${ci}$gebal
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! SGEHRD reduces a real general matrix A to upper Hessenberg form H by
!! an orthogonal similarity transformation: Q**T * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx
real(sp) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
lwkopt = n*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEHRD', -info )
return
else if( lquery ) then
return
end if
! set elements 1:ilo-1 and ihi:n-1 of tau to zero
do i = 1, ilo - 1
tau( i ) = zero
end do
do i = max( 1, ihi ), n - 1
tau( i ) = zero
end do
! quick return if possible
nh = ihi - ilo + 1_${ik}$
if( nh<=1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the block size
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
nbmin = 2_${ik}$
if( nb>1_${ik}$ .and. nb<nh ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code)
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'SGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
if( nx<nh ) then
! determine if workspace is large enough for blocked code
if( lwork<n*nb+tsize ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SGEHRD', ' ', n, ilo, ihi,-1_${ik}$ ) )
if( lwork>=(n*nbmin + tsize) ) then
nb = (lwork-tsize) / n
else
nb = 1_${ik}$
end if
end if
end if
end if
ldwork = n
if( nb<nbmin .or. nb>=nh ) then
! use unblocked code below
i = ilo
else
! use blocked code
iwt = 1_${ik}$ + n*nb
do i = ilo, ihi - 1 - nx, nb
ib = min( nb, ihi-i )
! reduce columns i:i+ib-1 to hessenberg form, returning the
! matrices v and t of the block reflector h = i - v*t*v**t
! which performs the reduction, and also the matrix y = a*v*t
call stdlib${ii}$_slahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, &
ldwork )
! apply the block reflector h to a(1:ihi,i+ib:ihi) from the
! right, computing a := a - y * v**t. v(i+ib,ib-1) must be set
! to 1
ei = a( i+ib, i+ib-1 )
a( i+ib, i+ib-1 ) = one
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, &
ldwork, a( i+ib, i ), lda, one,a( 1_${ik}$, i+ib ), lda )
a( i+ib, i+ib-1 ) = ei
! apply the block reflector h to a(1:i,i+1:i+ib-1) from the
! right
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )&
, lda, work, ldwork )
do j = 0, ib-2
call stdlib${ii}$_saxpy( i, -one, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ )
end do
! apply the block reflector h to a(i+1:ihi,i+ib:n) from the
! left
call stdlib${ii}$_slarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, &
ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, ldwork )
end do
end if
! use unblocked code to reduce the rest of the matrix
call stdlib${ii}$_sgehd2( n, i, ihi, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sgehrd
pure module subroutine stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! DGEHRD reduces a real general matrix A to upper Hessenberg form H by
!! an orthogonal similarity transformation: Q**T * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx
real(dp) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
lwkopt = n*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEHRD', -info )
return
else if( lquery ) then
return
end if
! set elements 1:ilo-1 and ihi:n-1 of tau to zero
do i = 1, ilo - 1
tau( i ) = zero
end do
do i = max( 1, ihi ), n - 1
tau( i ) = zero
end do
! quick return if possible
nh = ihi - ilo + 1_${ik}$
if( nh<=1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the block size
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
nbmin = 2_${ik}$
if( nb>1_${ik}$ .and. nb<nh ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code)
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'DGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
if( nx<nh ) then
! determine if workspace is large enough for blocked code
if( lwork<n*nb+tsize ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGEHRD', ' ', n, ilo, ihi,-1_${ik}$ ) )
if( lwork>=(n*nbmin + tsize) ) then
nb = (lwork-tsize) / n
else
nb = 1_${ik}$
end if
end if
end if
end if
ldwork = n
if( nb<nbmin .or. nb>=nh ) then
! use unblocked code below
i = ilo
else
! use blocked code
iwt = 1_${ik}$ + n*nb
do i = ilo, ihi - 1 - nx, nb
ib = min( nb, ihi-i )
! reduce columns i:i+ib-1 to hessenberg form, returning the
! matrices v and t of the block reflector h = i - v*t*v**t
! which performs the reduction, and also the matrix y = a*v*t
call stdlib${ii}$_dlahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, &
ldwork )
! apply the block reflector h to a(1:ihi,i+ib:ihi) from the
! right, computing a := a - y * v**t. v(i+ib,ib-1) must be set
! to 1
ei = a( i+ib, i+ib-1 )
a( i+ib, i+ib-1 ) = one
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, &
ldwork, a( i+ib, i ), lda, one,a( 1_${ik}$, i+ib ), lda )
a( i+ib, i+ib-1 ) = ei
! apply the block reflector h to a(1:i,i+1:i+ib-1) from the
! right
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )&
, lda, work, ldwork )
do j = 0, ib-2
call stdlib${ii}$_daxpy( i, -one, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ )
end do
! apply the block reflector h to a(i+1:ihi,i+ib:n) from the
! left
call stdlib${ii}$_dlarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, &
ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, ldwork )
end do
end if
! use unblocked code to reduce the rest of the matrix
call stdlib${ii}$_dgehd2( n, i, ihi, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dgehrd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! DGEHRD: reduces a real general matrix A to upper Hessenberg form H by
!! an orthogonal similarity transformation: Q**T * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx
real(${rk}$) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
lwkopt = n*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEHRD', -info )
return
else if( lquery ) then
return
end if
! set elements 1:ilo-1 and ihi:n-1 of tau to zero
do i = 1, ilo - 1
tau( i ) = zero
end do
do i = max( 1, ihi ), n - 1
tau( i ) = zero
end do
! quick return if possible
nh = ihi - ilo + 1_${ik}$
if( nh<=1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the block size
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
nbmin = 2_${ik}$
if( nb>1_${ik}$ .and. nb<nh ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code)
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'DGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
if( nx<nh ) then
! determine if workspace is large enough for blocked code
if( lwork<n*nb+tsize ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGEHRD', ' ', n, ilo, ihi,-1_${ik}$ ) )
if( lwork>=(n*nbmin + tsize) ) then
nb = (lwork-tsize) / n
else
nb = 1_${ik}$
end if
end if
end if
end if
ldwork = n
if( nb<nbmin .or. nb>=nh ) then
! use unblocked code below
i = ilo
else
! use blocked code
iwt = 1_${ik}$ + n*nb
do i = ilo, ihi - 1 - nx, nb
ib = min( nb, ihi-i )
! reduce columns i:i+ib-1 to hessenberg form, returning the
! matrices v and t of the block reflector h = i - v*t*v**t
! which performs the reduction, and also the matrix y = a*v*t
call stdlib${ii}$_${ri}$lahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, &
ldwork )
! apply the block reflector h to a(1:ihi,i+ib:ihi) from the
! right, computing a := a - y * v**t. v(i+ib,ib-1) must be set
! to 1
ei = a( i+ib, i+ib-1 )
a( i+ib, i+ib-1 ) = one
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, &
ldwork, a( i+ib, i ), lda, one,a( 1_${ik}$, i+ib ), lda )
a( i+ib, i+ib-1 ) = ei
! apply the block reflector h to a(1:i,i+1:i+ib-1) from the
! right
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )&
, lda, work, ldwork )
do j = 0, ib-2
call stdlib${ii}$_${ri}$axpy( i, -one, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ )
end do
! apply the block reflector h to a(i+1:ihi,i+ib:n) from the
! left
call stdlib${ii}$_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, &
ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, ldwork )
end do
end if
! use unblocked code to reduce the rest of the matrix
call stdlib${ii}$_${ri}$gehd2( n, i, ihi, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$gehrd
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! CGEHRD reduces a complex general matrix A to upper Hessenberg form H by
!! an unitary similarity transformation: Q**H * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx
complex(sp) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
lwkopt = n*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEHRD', -info )
return
else if( lquery ) then
return
end if
! set elements 1:ilo-1 and ihi:n-1 of tau to czero
do i = 1, ilo - 1
tau( i ) = czero
end do
do i = max( 1, ihi ), n - 1
tau( i ) = czero
end do
! quick return if possible
nh = ihi - ilo + 1_${ik}$
if( nh<=1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the block size
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
nbmin = 2_${ik}$
if( nb>1_${ik}$ .and. nb<nh ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code)
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'CGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
if( nx<nh ) then
! determine if workspace is large enough for blocked code
if( lwork<n*nb+tsize ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CGEHRD', ' ', n, ilo, ihi,-1_${ik}$ ) )
if( lwork>=(n*nbmin+tsize) ) then
nb = (lwork-tsize) / n
else
nb = 1_${ik}$
end if
end if
end if
end if
ldwork = n
if( nb<nbmin .or. nb>=nh ) then
! use unblocked code below
i = ilo
else
! use blocked code
iwt = 1_${ik}$ + n*nb
do i = ilo, ihi - 1 - nx, nb
ib = min( nb, ihi-i )
! reduce columns i:i+ib-1 to hessenberg form, returning the
! matrices v and t of the block reflector h = i - v*t*v**h
! which performs the reduction, and also the matrix y = a*v*t
call stdlib${ii}$_clahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, &
ldwork )
! apply the block reflector h to a(1:ihi,i+ib:ihi) from the
! right, computing a := a - y * v**h. v(i+ib,ib-1) must be set
! to 1
ei = a( i+ib, i+ib-1 )
a( i+ib, i+ib-1 ) = cone
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -&
cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1_${ik}$, i+ib ), lda )
a( i+ib, i+ib-1 ) = ei
! apply the block reflector h to a(1:i,i+1:i+ib-1) from the
! right
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, &
a( i+1, i ), lda, work, ldwork )
do j = 0, ib-2
call stdlib${ii}$_caxpy( i, -cone, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ )
end do
! apply the block reflector h to a(i+1:ihi,i+ib:n) from the
! left
call stdlib${ii}$_clarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, &
n-i-ib+1, ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, &
ldwork )
end do
end if
! use unblocked code to reduce the rest of the matrix
call stdlib${ii}$_cgehd2( n, i, ihi, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cgehrd
pure module subroutine stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by
!! an unitary similarity transformation: Q**H * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx
complex(dp) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
lwkopt = n*nb + tsize
work( 1_${ik}$ ) = lwkopt
endif
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEHRD', -info )
return
else if( lquery ) then
return
end if
! set elements 1:ilo-1 and ihi:n-1 of tau to czero
do i = 1, ilo - 1
tau( i ) = czero
end do
do i = max( 1, ihi ), n - 1
tau( i ) = czero
end do
! quick return if possible
nh = ihi - ilo + 1_${ik}$
if( nh<=1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the block size
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
nbmin = 2_${ik}$
if( nb>1_${ik}$ .and. nb<nh ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code)
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
if( nx<nh ) then
! determine if workspace is large enough for blocked code
if( lwork<n*nb+tsize ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGEHRD', ' ', n, ilo, ihi,-1_${ik}$ ) )
if( lwork>=(n*nbmin + tsize) ) then
nb = (lwork-tsize) / n
else
nb = 1_${ik}$
end if
end if
end if
end if
ldwork = n
if( nb<nbmin .or. nb>=nh ) then
! use unblocked code below
i = ilo
else
! use blocked code
iwt = 1_${ik}$ + n*nb
do i = ilo, ihi - 1 - nx, nb
ib = min( nb, ihi-i )
! reduce columns i:i+ib-1 to hessenberg form, returning the
! matrices v and t of the block reflector h = i - v*t*v**h
! which performs the reduction, and also the matrix y = a*v*t
call stdlib${ii}$_zlahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, &
ldwork )
! apply the block reflector h to a(1:ihi,i+ib:ihi) from the
! right, computing a := a - y * v**h. v(i+ib,ib-1) must be set
! to 1
ei = a( i+ib, i+ib-1 )
a( i+ib, i+ib-1 ) = cone
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -&
cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1_${ik}$, i+ib ), lda )
a( i+ib, i+ib-1 ) = ei
! apply the block reflector h to a(1:i,i+1:i+ib-1) from the
! right
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, &
a( i+1, i ), lda, work, ldwork )
do j = 0, ib-2
call stdlib${ii}$_zaxpy( i, -cone, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ )
end do
! apply the block reflector h to a(i+1:ihi,i+ib:n) from the
! left
call stdlib${ii}$_zlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, &
n-i-ib+1, ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, &
ldwork )
end do
end if
! use unblocked code to reduce the rest of the matrix
call stdlib${ii}$_zgehd2( n, i, ihi, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zgehrd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! ZGEHRD: reduces a complex general matrix A to upper Hessenberg form H by
!! an unitary similarity transformation: Q**H * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx
complex(${ck}$) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
lwkopt = n*nb + tsize
work( 1_${ik}$ ) = lwkopt
endif
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEHRD', -info )
return
else if( lquery ) then
return
end if
! set elements 1:ilo-1 and ihi:n-1 of tau to czero
do i = 1, ilo - 1
tau( i ) = czero
end do
do i = max( 1, ihi ), n - 1
tau( i ) = czero
end do
! quick return if possible
nh = ihi - ilo + 1_${ik}$
if( nh<=1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the block size
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
nbmin = 2_${ik}$
if( nb>1_${ik}$ .and. nb<nh ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code)
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZGEHRD', ' ', n, ilo, ihi, -1_${ik}$ ) )
if( nx<nh ) then
! determine if workspace is large enough for blocked code
if( lwork<n*nb+tsize ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGEHRD', ' ', n, ilo, ihi,-1_${ik}$ ) )
if( lwork>=(n*nbmin + tsize) ) then
nb = (lwork-tsize) / n
else
nb = 1_${ik}$
end if
end if
end if
end if
ldwork = n
if( nb<nbmin .or. nb>=nh ) then
! use unblocked code below
i = ilo
else
! use blocked code
iwt = 1_${ik}$ + n*nb
do i = ilo, ihi - 1 - nx, nb
ib = min( nb, ihi-i )
! reduce columns i:i+ib-1 to hessenberg form, returning the
! matrices v and t of the block reflector h = i - v*t*v**h
! which performs the reduction, and also the matrix y = a*v*t
call stdlib${ii}$_${ci}$lahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, &
ldwork )
! apply the block reflector h to a(1:ihi,i+ib:ihi) from the
! right, computing a := a - y * v**h. v(i+ib,ib-1) must be set
! to 1
ei = a( i+ib, i+ib-1 )
a( i+ib, i+ib-1 ) = cone
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -&
cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1_${ik}$, i+ib ), lda )
a( i+ib, i+ib-1 ) = ei
! apply the block reflector h to a(1:i,i+1:i+ib-1) from the
! right
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, &
a( i+1, i ), lda, work, ldwork )
do j = 0, ib-2
call stdlib${ii}$_${ci}$axpy( i, -cone, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ )
end do
! apply the block reflector h to a(i+1:ihi,i+ib:n) from the
! left
call stdlib${ii}$_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, &
n-i-ib+1, ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, &
ldwork )
end do
end if
! use unblocked code to reduce the rest of the matrix
call stdlib${ii}$_${ci}$gehd2( n, i, ihi, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$gehrd
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgehd2( n, ilo, ihi, a, lda, tau, work, info )
!! SGEHD2 reduces a real general matrix A to upper Hessenberg form H by
!! an orthogonal similarity transformation: Q**T * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) 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( 'SGEHD2', -info )
return
end if
do i = ilo, ihi - 1
! compute elementary reflector h(i) to annihilate a(i+2:ihi,i)
call stdlib${ii}$_slarfg( ihi-i, a( i+1, i ), a( min( i+2, n ), i ), 1_${ik}$,tau( i ) )
aii = a( i+1, i )
a( i+1, i ) = one
! apply h(i) to a(1:ihi,i+1:ihi) from the right
call stdlib${ii}$_slarf( 'RIGHT', ihi, ihi-i, a( i+1, i ), 1_${ik}$, tau( i ),a( 1_${ik}$, i+1 ), lda, &
work )
! apply h(i) to a(i+1:ihi,i+1:n) from the left
call stdlib${ii}$_slarf( 'LEFT', ihi-i, n-i, a( i+1, i ), 1_${ik}$, tau( i ),a( i+1, i+1 ), lda, &
work )
a( i+1, i ) = aii
end do
return
end subroutine stdlib${ii}$_sgehd2
pure module subroutine stdlib${ii}$_dgehd2( n, ilo, ihi, a, lda, tau, work, info )
!! DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
!! an orthogonal similarity transformation: Q**T * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) 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( 'DGEHD2', -info )
return
end if
do i = ilo, ihi - 1
! compute elementary reflector h(i) to annihilate a(i+2:ihi,i)
call stdlib${ii}$_dlarfg( ihi-i, a( i+1, i ), a( min( i+2, n ), i ), 1_${ik}$,tau( i ) )
aii = a( i+1, i )
a( i+1, i ) = one
! apply h(i) to a(1:ihi,i+1:ihi) from the right
call stdlib${ii}$_dlarf( 'RIGHT', ihi, ihi-i, a( i+1, i ), 1_${ik}$, tau( i ),a( 1_${ik}$, i+1 ), lda, &
work )
! apply h(i) to a(i+1:ihi,i+1:n) from the left
call stdlib${ii}$_dlarf( 'LEFT', ihi-i, n-i, a( i+1, i ), 1_${ik}$, tau( i ),a( i+1, i+1 ), lda, &
work )
a( i+1, i ) = aii
end do
return
end subroutine stdlib${ii}$_dgehd2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gehd2( n, ilo, ihi, a, lda, tau, work, info )
!! DGEHD2: reduces a real general matrix A to upper Hessenberg form H by
!! an orthogonal similarity transformation: Q**T * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${rk}$) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) 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( 'DGEHD2', -info )
return
end if
do i = ilo, ihi - 1
! compute elementary reflector h(i) to annihilate a(i+2:ihi,i)
call stdlib${ii}$_${ri}$larfg( ihi-i, a( i+1, i ), a( min( i+2, n ), i ), 1_${ik}$,tau( i ) )
aii = a( i+1, i )
a( i+1, i ) = one
! apply h(i) to a(1:ihi,i+1:ihi) from the right
call stdlib${ii}$_${ri}$larf( 'RIGHT', ihi, ihi-i, a( i+1, i ), 1_${ik}$, tau( i ),a( 1_${ik}$, i+1 ), lda, &
work )
! apply h(i) to a(i+1:ihi,i+1:n) from the left
call stdlib${ii}$_${ri}$larf( 'LEFT', ihi-i, n-i, a( i+1, i ), 1_${ik}$, tau( i ),a( i+1, i+1 ), lda, &
work )
a( i+1, i ) = aii
end do
return
end subroutine stdlib${ii}$_${ri}$gehd2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgehd2( n, ilo, ihi, a, lda, tau, work, info )
!! CGEHD2 reduces a complex general matrix A to upper Hessenberg form H
!! by a unitary similarity transformation: Q**H * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(sp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) 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( 'CGEHD2', -info )
return
end if
do i = ilo, ihi - 1
! compute elementary reflector h(i) to annihilate a(i+2:ihi,i)
alpha = a( i+1, i )
call stdlib${ii}$_clarfg( ihi-i, alpha, a( min( i+2, n ), i ), 1_${ik}$, tau( i ) )
a( i+1, i ) = cone
! apply h(i) to a(1:ihi,i+1:ihi) from the right
call stdlib${ii}$_clarf( 'RIGHT', ihi, ihi-i, a( i+1, i ), 1_${ik}$, tau( i ),a( 1_${ik}$, i+1 ), lda, &
work )
! apply h(i)**h to a(i+1:ihi,i+1:n) from the left
call stdlib${ii}$_clarf( 'LEFT', ihi-i, n-i, a( i+1, i ), 1_${ik}$,conjg( tau( i ) ), a( i+1, i+&
1_${ik}$ ), lda, work )
a( i+1, i ) = alpha
end do
return
end subroutine stdlib${ii}$_cgehd2
pure module subroutine stdlib${ii}$_zgehd2( n, ilo, ihi, a, lda, tau, work, info )
!! ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
!! by a unitary similarity transformation: Q**H * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(dp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) 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( 'ZGEHD2', -info )
return
end if
do i = ilo, ihi - 1
! compute elementary reflector h(i) to annihilate a(i+2:ihi,i)
alpha = a( i+1, i )
call stdlib${ii}$_zlarfg( ihi-i, alpha, a( min( i+2, n ), i ), 1_${ik}$, tau( i ) )
a( i+1, i ) = cone
! apply h(i) to a(1:ihi,i+1:ihi) from the right
call stdlib${ii}$_zlarf( 'RIGHT', ihi, ihi-i, a( i+1, i ), 1_${ik}$, tau( i ),a( 1_${ik}$, i+1 ), lda, &
work )
! apply h(i)**h to a(i+1:ihi,i+1:n) from the left
call stdlib${ii}$_zlarf( 'LEFT', ihi-i, n-i, a( i+1, i ), 1_${ik}$,conjg( tau( i ) ), a( i+1, i+&
1_${ik}$ ), lda, work )
a( i+1, i ) = alpha
end do
return
end subroutine stdlib${ii}$_zgehd2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gehd2( n, ilo, ihi, a, lda, tau, work, info )
!! ZGEHD2: reduces a complex general matrix A to upper Hessenberg form H
!! by a unitary similarity transformation: Q**H * A * Q = H .
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(${ck}$) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) 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( 'ZGEHD2', -info )
return
end if
do i = ilo, ihi - 1
! compute elementary reflector h(i) to annihilate a(i+2:ihi,i)
alpha = a( i+1, i )
call stdlib${ii}$_${ci}$larfg( ihi-i, alpha, a( min( i+2, n ), i ), 1_${ik}$, tau( i ) )
a( i+1, i ) = cone
! apply h(i) to a(1:ihi,i+1:ihi) from the right
call stdlib${ii}$_${ci}$larf( 'RIGHT', ihi, ihi-i, a( i+1, i ), 1_${ik}$, tau( i ),a( 1_${ik}$, i+1 ), lda, &
work )
! apply h(i)**h to a(i+1:ihi,i+1:n) from the left
call stdlib${ii}$_${ci}$larf( 'LEFT', ihi-i, n-i, a( i+1, i ), 1_${ik}$,conjg( tau( i ) ), a( i+1, i+&
1_${ik}$ ), lda, work )
a( i+1, i ) = alpha
end do
return
end subroutine stdlib${ii}$_${ci}$gehd2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info )
!! SGEBAK forms the right or left eigenvectors of a real general matrix
!! by backward transformation on the computed eigenvectors of the
!! balanced matrix output by SGEBAL.
! -- 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) :: job, side
integer(${ik}$), intent(in) :: ihi, ilo, ldv, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(sp), intent(inout) :: v(ldv,*)
real(sp), intent(in) :: scale(*)
! =====================================================================
! Local Scalars
logical(lk) :: leftv, rightv
integer(${ik}$) :: i, ii, k
real(sp) :: s
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
rightv = stdlib_lsame( side, 'R' )
leftv = stdlib_lsame( side, 'L' )
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) then
info = -1_${ik}$
else if( .not.rightv .and. .not.leftv ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -7_${ik}$
else if( ldv<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEBAK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( m==0 )return
if( stdlib_lsame( job, 'N' ) )return
if( ilo==ihi )go to 30
! backward balance
if( stdlib_lsame( job, 'S' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
do i = ilo, ihi
s = scale( i )
call stdlib${ii}$_sscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
if( leftv ) then
do i = ilo, ihi
s = one / scale( i )
call stdlib${ii}$_sscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
end if
! backward permutation
! for i = ilo-1 step -1 until 1,
! ihi+1 step 1 until n do --
30 continue
if( stdlib_lsame( job, 'P' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
loop_40: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_40
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_40
call stdlib${ii}$_sswap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_40
end if
if( leftv ) then
loop_50: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_50
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_50
call stdlib${ii}$_sswap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_50
end if
end if
return
end subroutine stdlib${ii}$_sgebak
pure module subroutine stdlib${ii}$_dgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info )
!! DGEBAK forms the right or left eigenvectors of a real general matrix
!! by backward transformation on the computed eigenvectors of the
!! balanced matrix output by DGEBAL.
! -- 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) :: job, side
integer(${ik}$), intent(in) :: ihi, ilo, ldv, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(dp), intent(in) :: scale(*)
real(dp), intent(inout) :: v(ldv,*)
! =====================================================================
! Local Scalars
logical(lk) :: leftv, rightv
integer(${ik}$) :: i, ii, k
real(dp) :: s
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
rightv = stdlib_lsame( side, 'R' )
leftv = stdlib_lsame( side, 'L' )
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) then
info = -1_${ik}$
else if( .not.rightv .and. .not.leftv ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -7_${ik}$
else if( ldv<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEBAK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( m==0 )return
if( stdlib_lsame( job, 'N' ) )return
if( ilo==ihi )go to 30
! backward balance
if( stdlib_lsame( job, 'S' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
do i = ilo, ihi
s = scale( i )
call stdlib${ii}$_dscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
if( leftv ) then
do i = ilo, ihi
s = one / scale( i )
call stdlib${ii}$_dscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
end if
! backward permutation
! for i = ilo-1 step -1 until 1,
! ihi+1 step 1 until n do --
30 continue
if( stdlib_lsame( job, 'P' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
loop_40: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_40
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_40
call stdlib${ii}$_dswap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_40
end if
if( leftv ) then
loop_50: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_50
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_50
call stdlib${ii}$_dswap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_50
end if
end if
return
end subroutine stdlib${ii}$_dgebak
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gebak( job, side, n, ilo, ihi, scale, m, v, ldv,info )
!! DGEBAK: forms the right or left eigenvectors of a real general matrix
!! by backward transformation on the computed eigenvectors of the
!! balanced matrix output by DGEBAL.
! -- 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) :: job, side
integer(${ik}$), intent(in) :: ihi, ilo, ldv, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(${rk}$), intent(in) :: scale(*)
real(${rk}$), intent(inout) :: v(ldv,*)
! =====================================================================
! Local Scalars
logical(lk) :: leftv, rightv
integer(${ik}$) :: i, ii, k
real(${rk}$) :: s
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
rightv = stdlib_lsame( side, 'R' )
leftv = stdlib_lsame( side, 'L' )
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) then
info = -1_${ik}$
else if( .not.rightv .and. .not.leftv ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -7_${ik}$
else if( ldv<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEBAK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( m==0 )return
if( stdlib_lsame( job, 'N' ) )return
if( ilo==ihi )go to 30
! backward balance
if( stdlib_lsame( job, 'S' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
do i = ilo, ihi
s = scale( i )
call stdlib${ii}$_${ri}$scal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
if( leftv ) then
do i = ilo, ihi
s = one / scale( i )
call stdlib${ii}$_${ri}$scal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
end if
! backward permutation
! for i = ilo-1 step -1 until 1,
! ihi+1 step 1 until n do --
30 continue
if( stdlib_lsame( job, 'P' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
loop_40: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_40
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_40
call stdlib${ii}$_${ri}$swap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_40
end if
if( leftv ) then
loop_50: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_50
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_50
call stdlib${ii}$_${ri}$swap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_50
end if
end if
return
end subroutine stdlib${ii}$_${ri}$gebak
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info )
!! CGEBAK forms the right or left eigenvectors of a complex general
!! matrix by backward transformation on the computed eigenvectors of the
!! balanced matrix output by CGEBAL.
! -- 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) :: job, side
integer(${ik}$), intent(in) :: ihi, ilo, ldv, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(sp), intent(in) :: scale(*)
complex(sp), intent(inout) :: v(ldv,*)
! =====================================================================
! Local Scalars
logical(lk) :: leftv, rightv
integer(${ik}$) :: i, ii, k
real(sp) :: s
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
rightv = stdlib_lsame( side, 'R' )
leftv = stdlib_lsame( side, 'L' )
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) then
info = -1_${ik}$
else if( .not.rightv .and. .not.leftv ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -7_${ik}$
else if( ldv<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEBAK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( m==0 )return
if( stdlib_lsame( job, 'N' ) )return
if( ilo==ihi )go to 30
! backward balance
if( stdlib_lsame( job, 'S' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
do i = ilo, ihi
s = scale( i )
call stdlib${ii}$_csscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
if( leftv ) then
do i = ilo, ihi
s = one / scale( i )
call stdlib${ii}$_csscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
end if
! backward permutation
! for i = ilo-1 step -1 until 1,
! ihi+1 step 1 until n do --
30 continue
if( stdlib_lsame( job, 'P' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
loop_40: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_40
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_40
call stdlib${ii}$_cswap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_40
end if
if( leftv ) then
loop_50: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_50
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_50
call stdlib${ii}$_cswap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_50
end if
end if
return
end subroutine stdlib${ii}$_cgebak
pure module subroutine stdlib${ii}$_zgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info )
!! ZGEBAK forms the right or left eigenvectors of a complex general
!! matrix by backward transformation on the computed eigenvectors of the
!! balanced matrix output by ZGEBAL.
! -- 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) :: job, side
integer(${ik}$), intent(in) :: ihi, ilo, ldv, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(dp), intent(in) :: scale(*)
complex(dp), intent(inout) :: v(ldv,*)
! =====================================================================
! Local Scalars
logical(lk) :: leftv, rightv
integer(${ik}$) :: i, ii, k
real(dp) :: s
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
rightv = stdlib_lsame( side, 'R' )
leftv = stdlib_lsame( side, 'L' )
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) then
info = -1_${ik}$
else if( .not.rightv .and. .not.leftv ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -7_${ik}$
else if( ldv<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEBAK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( m==0 )return
if( stdlib_lsame( job, 'N' ) )return
if( ilo==ihi )go to 30
! backward balance
if( stdlib_lsame( job, 'S' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
do i = ilo, ihi
s = scale( i )
call stdlib${ii}$_zdscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
if( leftv ) then
do i = ilo, ihi
s = one / scale( i )
call stdlib${ii}$_zdscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
end if
! backward permutation
! for i = ilo-1 step -1 until 1,
! ihi+1 step 1 until n do --
30 continue
if( stdlib_lsame( job, 'P' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
loop_40: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_40
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_40
call stdlib${ii}$_zswap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_40
end if
if( leftv ) then
loop_50: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_50
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_50
call stdlib${ii}$_zswap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_50
end if
end if
return
end subroutine stdlib${ii}$_zgebak
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gebak( job, side, n, ilo, ihi, scale, m, v, ldv,info )
!! ZGEBAK: forms the right or left eigenvectors of a complex general
!! matrix by backward transformation on the computed eigenvectors of the
!! balanced matrix output by ZGEBAL.
! -- 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) :: job, side
integer(${ik}$), intent(in) :: ihi, ilo, ldv, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(${ck}$), intent(in) :: scale(*)
complex(${ck}$), intent(inout) :: v(ldv,*)
! =====================================================================
! Local Scalars
logical(lk) :: leftv, rightv
integer(${ik}$) :: i, ii, k
real(${ck}$) :: s
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
rightv = stdlib_lsame( side, 'R' )
leftv = stdlib_lsame( side, 'L' )
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) &
.and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) then
info = -1_${ik}$
else if( .not.rightv .and. .not.leftv ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( m<0_${ik}$ ) then
info = -7_${ik}$
else if( ldv<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEBAK', -info )
return
end if
! quick return if possible
if( n==0 )return
if( m==0 )return
if( stdlib_lsame( job, 'N' ) )return
if( ilo==ihi )go to 30
! backward balance
if( stdlib_lsame( job, 'S' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
do i = ilo, ihi
s = scale( i )
call stdlib${ii}$_${ci}$dscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
if( leftv ) then
do i = ilo, ihi
s = one / scale( i )
call stdlib${ii}$_${ci}$dscal( m, s, v( i, 1_${ik}$ ), ldv )
end do
end if
end if
! backward permutation
! for i = ilo-1 step -1 until 1,
! ihi+1 step 1 until n do --
30 continue
if( stdlib_lsame( job, 'P' ) .or. stdlib_lsame( job, 'B' ) ) then
if( rightv ) then
loop_40: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_40
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_40
call stdlib${ii}$_${ci}$swap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_40
end if
if( leftv ) then
loop_50: do ii = 1, n
i = ii
if( i>=ilo .and. i<=ihi )cycle loop_50
if( i<ilo )i = ilo - ii
k = scale( i )
if( k==i )cycle loop_50
call stdlib${ii}$_${ci}$swap( m, v( i, 1_${ik}$ ), ldv, v( k, 1_${ik}$ ), ldv )
end do loop_50
end if
end if
return
end subroutine stdlib${ii}$_${ci}$gebak
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy )
!! SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)
!! matrix A so that elements below the k-th subdiagonal are zero. The
!! reduction is performed by an orthogonal similarity transformation
!! Q**T * A * Q. The routine returns the matrices V and T which determine
!! Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T.
!! This is an auxiliary routine called by SGEHRD.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: ei
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1 )return
loop_10: do i = 1, nb
if( i>1_${ik}$ ) then
! update a(k+1:n,i)
! update i-th column of a - y * v**t
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), &
lda, one, a( k+1, i ), 1_${ik}$ )
! apply i - v * t**t * v**t to this column (call it b) from the
! left, using the last column of t as workspace
! let v = ( v1 ) and b = ( b1 ) (first i-1 rows)
! ( v2 ) ( b2 )
! where v1 is unit lower triangular
! w := v1**t * b1
call stdlib${ii}$_scopy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ )
call stdlib${ii}$_strmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, t( 1_${ik}$, nb ),&
1_${ik}$ )
! w := w + v2**t * b2
call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ),lda, a( k+i, i ), &
1_${ik}$, one, t( 1_${ik}$, nb ), 1_${ik}$ )
! w := t**t * w
call stdlib${ii}$_strmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, nb ), 1_${ik}$ )
! b2 := b2 - v2*w
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb )&
, 1_${ik}$, one, a( k+i, i ), 1_${ik}$ )
! b1 := b1 - v1*w
call stdlib${ii}$_strmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, &
nb ), 1_${ik}$ )
call stdlib${ii}$_saxpy( i-1, -one, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ )
a( k+i-1, i-1 ) = ei
end if
! generate the elementary reflector h(i) to annihilate
! a(k+i+1:n,i)
call stdlib${ii}$_slarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) )
ei = a( k+i, i )
a( k+i, i ) = one
! compute y(k+1:n,i)
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),&
1_${ik}$, zero, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ), lda,a( k+i, i ), 1_${ik}$, &
zero, t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, &
one, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ )
! compute t(1:i,i)
call stdlib${ii}$_sscal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_strmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ )
t( i, i ) = tau( i )
end do loop_10
a( k+nb, nb ) = ei
! compute y(1:k,1:nb)
call stdlib${ii}$_slacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy )
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1_${ik}$ ), &
lda, y, ldy )
if( n>k+nb )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1_${ik}$, &
2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, one, y,ldy )
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, &
ldy )
return
end subroutine stdlib${ii}$_slahr2
pure module subroutine stdlib${ii}$_dlahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy )
!! DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)
!! matrix A so that elements below the k-th subdiagonal are zero. The
!! reduction is performed by an orthogonal similarity transformation
!! Q**T * A * Q. The routine returns the matrices V and T which determine
!! Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T.
!! This is an auxiliary routine called by DGEHRD.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: ei
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1 )return
loop_10: do i = 1, nb
if( i>1_${ik}$ ) then
! update a(k+1:n,i)
! update i-th column of a - y * v**t
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), &
lda, one, a( k+1, i ), 1_${ik}$ )
! apply i - v * t**t * v**t to this column (call it b) from the
! left, using the last column of t as workspace
! let v = ( v1 ) and b = ( b1 ) (first i-1 rows)
! ( v2 ) ( b2 )
! where v1 is unit lower triangular
! w := v1**t * b1
call stdlib${ii}$_dcopy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ )
call stdlib${ii}$_dtrmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, t( 1_${ik}$, nb ),&
1_${ik}$ )
! w := w + v2**t * b2
call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ),lda, a( k+i, i ), &
1_${ik}$, one, t( 1_${ik}$, nb ), 1_${ik}$ )
! w := t**t * w
call stdlib${ii}$_dtrmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, nb ), 1_${ik}$ )
! b2 := b2 - v2*w
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb )&
, 1_${ik}$, one, a( k+i, i ), 1_${ik}$ )
! b1 := b1 - v1*w
call stdlib${ii}$_dtrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, &
nb ), 1_${ik}$ )
call stdlib${ii}$_daxpy( i-1, -one, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ )
a( k+i-1, i-1 ) = ei
end if
! generate the elementary reflector h(i) to annihilate
! a(k+i+1:n,i)
call stdlib${ii}$_dlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) )
ei = a( k+i, i )
a( k+i, i ) = one
! compute y(k+1:n,i)
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),&
1_${ik}$, zero, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ), lda,a( k+i, i ), 1_${ik}$, &
zero, t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, &
one, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ )
! compute t(1:i,i)
call stdlib${ii}$_dscal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dtrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ )
t( i, i ) = tau( i )
end do loop_10
a( k+nb, nb ) = ei
! compute y(1:k,1:nb)
call stdlib${ii}$_dlacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy )
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1_${ik}$ ), &
lda, y, ldy )
if( n>k+nb )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1_${ik}$, &
2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, one, y,ldy )
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, &
ldy )
return
end subroutine stdlib${ii}$_dlahr2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy )
!! DLAHR2: reduces the first NB columns of A real general n-BY-(n-k+1)
!! matrix A so that elements below the k-th subdiagonal are zero. The
!! reduction is performed by an orthogonal similarity transformation
!! Q**T * A * Q. The routine returns the matrices V and T which determine
!! Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T.
!! This is an auxiliary routine called by DGEHRD.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${rk}$) :: ei
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1 )return
loop_10: do i = 1, nb
if( i>1_${ik}$ ) then
! update a(k+1:n,i)
! update i-th column of a - y * v**t
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), &
lda, one, a( k+1, i ), 1_${ik}$ )
! apply i - v * t**t * v**t to this column (call it b) from the
! left, using the last column of t as workspace
! let v = ( v1 ) and b = ( b1 ) (first i-1 rows)
! ( v2 ) ( b2 )
! where v1 is unit lower triangular
! w := v1**t * b1
call stdlib${ii}$_${ri}$copy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ )
call stdlib${ii}$_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, t( 1_${ik}$, nb ),&
1_${ik}$ )
! w := w + v2**t * b2
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ),lda, a( k+i, i ), &
1_${ik}$, one, t( 1_${ik}$, nb ), 1_${ik}$ )
! w := t**t * w
call stdlib${ii}$_${ri}$trmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, nb ), 1_${ik}$ )
! b2 := b2 - v2*w
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb )&
, 1_${ik}$, one, a( k+i, i ), 1_${ik}$ )
! b1 := b1 - v1*w
call stdlib${ii}$_${ri}$trmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, &
nb ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( i-1, -one, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ )
a( k+i-1, i-1 ) = ei
end if
! generate the elementary reflector h(i) to annihilate
! a(k+i+1:n,i)
call stdlib${ii}$_${ri}$larfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) )
ei = a( k+i, i )
a( k+i, i ) = one
! compute y(k+1:n,i)
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),&
1_${ik}$, zero, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ), lda,a( k+i, i ), 1_${ik}$, &
zero, t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, &
one, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ )
! compute t(1:i,i)
call stdlib${ii}$_${ri}$scal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ )
t( i, i ) = tau( i )
end do loop_10
a( k+nb, nb ) = ei
! compute y(1:k,1:nb)
call stdlib${ii}$_${ri}$lacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy )
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1_${ik}$ ), &
lda, y, ldy )
if( n>k+nb )call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1_${ik}$, &
2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, one, y,ldy )
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, &
ldy )
return
end subroutine stdlib${ii}$_${ri}$lahr2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy )
!! CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
!! matrix A so that elements below the k-th subdiagonal are zero. The
!! reduction is performed by an unitary similarity transformation
!! Q**H * A * Q. The routine returns the matrices V and T which determine
!! Q as a block reflector I - V*T*v**H, and also the matrix Y = A * V * T.
!! This is an auxiliary routine called by CGEHRD.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(sp) :: ei
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1 )return
loop_10: do i = 1, nb
if( i>1_${ik}$ ) then
! update a(k+1:n,i)
! update i-th column of a - y * v**h
call stdlib${ii}$_clacgv( i-1, a( k+i-1, 1_${ik}$ ), lda )
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), &
lda, cone, a( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_clacgv( i-1, a( k+i-1, 1_${ik}$ ), lda )
! apply i - v * t**h * v**h to this column (call it b) from the
! left, using the last column of t as workspace
! let v = ( v1 ) and b = ( b1 ) (first i-1 rows)
! ( v2 ) ( b2 )
! where v1 is unit lower triangular
! w := v1**h * b1
call stdlib${ii}$_ccopy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ )
call stdlib${ii}$_ctrmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, &
t( 1_${ik}$, nb ), 1_${ik}$ )
! w := w + v2**h * b2
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ),lda, a( &
k+i, i ), 1_${ik}$, cone, t( 1_${ik}$, nb ), 1_${ik}$ )
! w := t**h * w
call stdlib${ii}$_ctrmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, &
nb ), 1_${ik}$ )
! b2 := b2 - v2*w
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb &
), 1_${ik}$, cone, a( k+i, i ), 1_${ik}$ )
! b1 := b1 - v1*w
call stdlib${ii}$_ctrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, &
nb ), 1_${ik}$ )
call stdlib${ii}$_caxpy( i-1, -cone, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ )
a( k+i-1, i-1 ) = ei
end if
! generate the elementary reflector h(i) to annihilate
! a(k+i+1:n,i)
call stdlib${ii}$_clarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) )
ei = a( k+i, i )
a( k+i, i ) = cone
! compute y(k+1:n,i)
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )&
, 1_${ik}$, czero, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ), lda,a( k+&
i, i ), 1_${ik}$, czero, t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, &
cone, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_cscal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ )
! compute t(1:i,i)
call stdlib${ii}$_cscal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_ctrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ )
t( i, i ) = tau( i )
end do loop_10
a( k+nb, nb ) = ei
! compute y(1:k,1:nb)
call stdlib${ii}$_clacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy )
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1_${ik}$ ), &
lda, y, ldy )
if( n>k+nb )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1_${ik}$,&
2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, cone, y,ldy )
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, &
ldy )
return
end subroutine stdlib${ii}$_clahr2
pure module subroutine stdlib${ii}$_zlahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy )
!! ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
!! matrix A so that elements below the k-th subdiagonal are zero. The
!! reduction is performed by an unitary similarity transformation
!! Q**H * A * Q. The routine returns the matrices V and T which determine
!! Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
!! This is an auxiliary routine called by ZGEHRD.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(dp) :: ei
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1 )return
loop_10: do i = 1, nb
if( i>1_${ik}$ ) then
! update a(k+1:n,i)
! update i-th column of a - y * v**h
call stdlib${ii}$_zlacgv( i-1, a( k+i-1, 1_${ik}$ ), lda )
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), &
lda, cone, a( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( i-1, a( k+i-1, 1_${ik}$ ), lda )
! apply i - v * t**h * v**h to this column (call it b) from the
! left, using the last column of t as workspace
! let v = ( v1 ) and b = ( b1 ) (first i-1 rows)
! ( v2 ) ( b2 )
! where v1 is unit lower triangular
! w := v1**h * b1
call stdlib${ii}$_zcopy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ )
call stdlib${ii}$_ztrmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, &
t( 1_${ik}$, nb ), 1_${ik}$ )
! w := w + v2**h * b2
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ),lda, a( &
k+i, i ), 1_${ik}$, cone, t( 1_${ik}$, nb ), 1_${ik}$ )
! w := t**h * w
call stdlib${ii}$_ztrmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, &
nb ), 1_${ik}$ )
! b2 := b2 - v2*w
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb &
), 1_${ik}$, cone, a( k+i, i ), 1_${ik}$ )
! b1 := b1 - v1*w
call stdlib${ii}$_ztrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, &
nb ), 1_${ik}$ )
call stdlib${ii}$_zaxpy( i-1, -cone, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ )
a( k+i-1, i-1 ) = ei
end if
! generate the elementary reflector h(i) to annihilate
! a(k+i+1:n,i)
call stdlib${ii}$_zlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) )
ei = a( k+i, i )
a( k+i, i ) = cone
! compute y(k+1:n,i)
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )&
, 1_${ik}$, czero, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ), lda,a( k+&
i, i ), 1_${ik}$, czero, t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, &
cone, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_zscal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ )
! compute t(1:i,i)
call stdlib${ii}$_zscal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_ztrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ )
t( i, i ) = tau( i )
end do loop_10
a( k+nb, nb ) = ei
! compute y(1:k,1:nb)
call stdlib${ii}$_zlacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy )
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1_${ik}$ ), &
lda, y, ldy )
if( n>k+nb )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1_${ik}$,&
2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, cone, y,ldy )
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, &
ldy )
return
end subroutine stdlib${ii}$_zlahr2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy )
!! ZLAHR2: reduces the first NB columns of A complex general n-BY-(n-k+1)
!! matrix A so that elements below the k-th subdiagonal are zero. The
!! reduction is performed by an unitary similarity transformation
!! Q**H * A * Q. The routine returns the matrices V and T which determine
!! Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
!! This is an auxiliary routine called by ZGEHRD.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(${ck}$) :: ei
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1 )return
loop_10: do i = 1, nb
if( i>1_${ik}$ ) then
! update a(k+1:n,i)
! update i-th column of a - y * v**h
call stdlib${ii}$_${ci}$lacgv( i-1, a( k+i-1, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), &
lda, cone, a( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( i-1, a( k+i-1, 1_${ik}$ ), lda )
! apply i - v * t**h * v**h to this column (call it b) from the
! left, using the last column of t as workspace
! let v = ( v1 ) and b = ( b1 ) (first i-1 rows)
! ( v2 ) ( b2 )
! where v1 is unit lower triangular
! w := v1**h * b1
call stdlib${ii}$_${ci}$copy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ )
call stdlib${ii}$_${ci}$trmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, &
t( 1_${ik}$, nb ), 1_${ik}$ )
! w := w + v2**h * b2
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ),lda, a( &
k+i, i ), 1_${ik}$, cone, t( 1_${ik}$, nb ), 1_${ik}$ )
! w := t**h * w
call stdlib${ii}$_${ci}$trmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, &
nb ), 1_${ik}$ )
! b2 := b2 - v2*w
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb &
), 1_${ik}$, cone, a( k+i, i ), 1_${ik}$ )
! b1 := b1 - v1*w
call stdlib${ii}$_${ci}$trmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, &
nb ), 1_${ik}$ )
call stdlib${ii}$_${ci}$axpy( i-1, -cone, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ )
a( k+i-1, i-1 ) = ei
end if
! generate the elementary reflector h(i) to annihilate
! a(k+i+1:n,i)
call stdlib${ii}$_${ci}$larfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) )
ei = a( k+i, i )
a( k+i, i ) = cone
! compute y(k+1:n,i)
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )&
, 1_${ik}$, czero, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ), lda,a( k+&
i, i ), 1_${ik}$, czero, t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, &
cone, y( k+1, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$scal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ )
! compute t(1:i,i)
call stdlib${ii}$_${ci}$scal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ )
t( i, i ) = tau( i )
end do loop_10
a( k+nb, nb ) = ei
! compute y(1:k,1:nb)
call stdlib${ii}$_${ci}$lacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy )
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1_${ik}$ ), &
lda, y, ldy )
if( n>k+nb )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1_${ik}$,&
2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, cone, y,ldy )
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, &
ldy )
return
end subroutine stdlib${ii}$_${ci}$lahr2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunghr( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! CUNGHR generates a complex unitary matrix Q which is defined as the
!! product of IHI-ILO elementary reflectors of order N, as returned by
!! CGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(in) :: tau(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, nh ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', nh, nh, nh, -1_${ik}$ )
lwkopt = max( 1_${ik}$, nh )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNGHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! shift the vectors which define the elementary reflectors cone
! column to the right, and set the first ilo and the last n-ihi
! rows and columns to those of the unit matrix
do j = ihi, ilo + 1, -1
do i = 1, j - 1
a( i, j ) = czero
end do
do i = j + 1, ihi
a( i, j ) = a( i, j-1 )
end do
do i = ihi + 1, n
a( i, j ) = czero
end do
end do
do j = 1, ilo
do i = 1, n
a( i, j ) = czero
end do
a( j, j ) = cone
end do
do j = ihi + 1, n
do i = 1, n
a( i, j ) = czero
end do
a( j, j ) = cone
end do
if( nh>0_${ik}$ ) then
! generate q(ilo+1:ihi,ilo+1:ihi)
call stdlib${ii}$_cungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, &
iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cunghr
pure module subroutine stdlib${ii}$_zunghr( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! ZUNGHR generates a complex unitary matrix Q which is defined as the
!! product of IHI-ILO elementary reflectors of order N, as returned by
!! ZGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(in) :: tau(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, nh ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', nh, nh, nh, -1_${ik}$ )
lwkopt = max( 1_${ik}$, nh )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! shift the vectors which define the elementary reflectors cone
! column to the right, and set the first ilo and the last n-ihi
! rows and columns to those of the unit matrix
do j = ihi, ilo + 1, -1
do i = 1, j - 1
a( i, j ) = czero
end do
do i = j + 1, ihi
a( i, j ) = a( i, j-1 )
end do
do i = ihi + 1, n
a( i, j ) = czero
end do
end do
do j = 1, ilo
do i = 1, n
a( i, j ) = czero
end do
a( j, j ) = cone
end do
do j = ihi + 1, n
do i = 1, n
a( i, j ) = czero
end do
a( j, j ) = cone
end do
if( nh>0_${ik}$ ) then
! generate q(ilo+1:ihi,ilo+1:ihi)
call stdlib${ii}$_zungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, &
iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zunghr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unghr( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! ZUNGHR: generates a complex unitary matrix Q which is defined as the
!! product of IHI-ILO elementary reflectors of order N, as returned by
!! ZGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(in) :: tau(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, nh ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', nh, nh, nh, -1_${ik}$ )
lwkopt = max( 1_${ik}$, nh )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! shift the vectors which define the elementary reflectors cone
! column to the right, and set the first ilo and the last n-ihi
! rows and columns to those of the unit matrix
do j = ihi, ilo + 1, -1
do i = 1, j - 1
a( i, j ) = czero
end do
do i = j + 1, ihi
a( i, j ) = a( i, j-1 )
end do
do i = ihi + 1, n
a( i, j ) = czero
end do
end do
do j = 1, ilo
do i = 1, n
a( i, j ) = czero
end do
a( j, j ) = cone
end do
do j = ihi + 1, n
do i = 1, n
a( i, j ) = czero
end do
a( j, j ) = cone
end do
if( nh>0_${ik}$ ) then
! generate q(ilo+1:ihi,ilo+1:ihi)
call stdlib${ii}$_${ci}$ungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, &
iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$unghr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, &
!! CUNMHR overwrites the general complex M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'C': Q**H * C C * Q**H
!! where Q is a complex unitary matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! IHI-ILO elementary reflectors, as returned by CGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
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) :: side, trans
integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(sp), intent(inout) :: a(lda,*), c(ldc,*)
complex(sp), intent(in) :: tau(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
left = stdlib_lsame( side, 'L' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )&
then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then
info = -5_${ik}$
else if( ihi<min( ilo, nq ) .or. ihi>nq ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', side // trans, nh, n, nh, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', side // trans, m, nh, nh, -1_${ik}$ )
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNMHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nh==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = nh
ni = n
i1 = ilo + 1_${ik}$
i2 = 1_${ik}$
else
mi = m
ni = nh
i1 = 1_${ik}$
i2 = ilo + 1_${ik}$
end if
call stdlib${ii}$_cunmqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, &
i2 ), ldc, work, lwork, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cunmhr
pure module subroutine stdlib${ii}$_zunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, &
!! ZUNMHR overwrites the general complex M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'C': Q**H * C C * Q**H
!! where Q is a complex unitary matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! IHI-ILO elementary reflectors, as returned by ZGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
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) :: side, trans
integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(dp), intent(inout) :: a(lda,*), c(ldc,*)
complex(dp), intent(in) :: tau(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
left = stdlib_lsame( side, 'L' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )&
then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then
info = -5_${ik}$
else if( ihi<min( ilo, nq ) .or. ihi>nq ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, nh, n, nh, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m, nh, nh, -1_${ik}$ )
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNMHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nh==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = nh
ni = n
i1 = ilo + 1_${ik}$
i2 = 1_${ik}$
else
mi = m
ni = nh
i1 = 1_${ik}$
i2 = ilo + 1_${ik}$
end if
call stdlib${ii}$_zunmqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, &
i2 ), ldc, work, lwork, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zunmhr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, &
!! ZUNMHR: overwrites the general complex M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'C': Q**H * C C * Q**H
!! where Q is a complex unitary matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! IHI-ILO elementary reflectors, as returned by ZGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
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) :: side, trans
integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*)
complex(${ck}$), intent(in) :: tau(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
left = stdlib_lsame( side, 'L' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )&
then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then
info = -5_${ik}$
else if( ihi<min( ilo, nq ) .or. ihi>nq ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, nh, n, nh, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m, nh, nh, -1_${ik}$ )
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNMHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nh==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = nh
ni = n
i1 = ilo + 1_${ik}$
i2 = 1_${ik}$
else
mi = m
ni = nh
i1 = 1_${ik}$
i2 = ilo + 1_${ik}$
end if
call stdlib${ii}$_${ci}$unmqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, &
i2 ), ldc, work, lwork, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$unmhr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sorghr( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! SORGHR generates a real orthogonal matrix Q which is defined as the
!! product of IHI-ILO elementary reflectors of order N, as returned by
!! SGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(in) :: tau(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, nh ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', nh, nh, nh, -1_${ik}$ )
lwkopt = max( 1_${ik}$, nh )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORGHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! shift the vectors which define the elementary reflectors one
! column to the right, and set the first ilo and the last n-ihi
! rows and columns to those of the unit matrix
do j = ihi, ilo + 1, -1
do i = 1, j - 1
a( i, j ) = zero
end do
do i = j + 1, ihi
a( i, j ) = a( i, j-1 )
end do
do i = ihi + 1, n
a( i, j ) = zero
end do
end do
do j = 1, ilo
do i = 1, n
a( i, j ) = zero
end do
a( j, j ) = one
end do
do j = ihi + 1, n
do i = 1, n
a( i, j ) = zero
end do
a( j, j ) = one
end do
if( nh>0_${ik}$ ) then
! generate q(ilo+1:ihi,ilo+1:ihi)
call stdlib${ii}$_sorgqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, &
iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sorghr
pure module subroutine stdlib${ii}$_dorghr( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! DORGHR generates a real orthogonal matrix Q which is defined as the
!! product of IHI-ILO elementary reflectors of order N, as returned by
!! DGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(in) :: tau(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, nh ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', nh, nh, nh, -1_${ik}$ )
lwkopt = max( 1_${ik}$, nh )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! shift the vectors which define the elementary reflectors one
! column to the right, and set the first ilo and the last n-ihi
! rows and columns to those of the unit matrix
do j = ihi, ilo + 1, -1
do i = 1, j - 1
a( i, j ) = zero
end do
do i = j + 1, ihi
a( i, j ) = a( i, j-1 )
end do
do i = ihi + 1, n
a( i, j ) = zero
end do
end do
do j = 1, ilo
do i = 1, n
a( i, j ) = zero
end do
a( j, j ) = one
end do
do j = ihi + 1, n
do i = 1, n
a( i, j ) = zero
end do
a( j, j ) = one
end do
if( nh>0_${ik}$ ) then
! generate q(ilo+1:ihi,ilo+1:ihi)
call stdlib${ii}$_dorgqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, &
iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dorghr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$orghr( n, ilo, ihi, a, lda, tau, work, lwork, info )
!! DORGHR: generates a real orthogonal matrix Q which is defined as the
!! product of IHI-ILO elementary reflectors of order N, as returned by
!! DGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(in) :: tau(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -2_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, nh ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', nh, nh, nh, -1_${ik}$ )
lwkopt = max( 1_${ik}$, nh )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! shift the vectors which define the elementary reflectors one
! column to the right, and set the first ilo and the last n-ihi
! rows and columns to those of the unit matrix
do j = ihi, ilo + 1, -1
do i = 1, j - 1
a( i, j ) = zero
end do
do i = j + 1, ihi
a( i, j ) = a( i, j-1 )
end do
do i = ihi + 1, n
a( i, j ) = zero
end do
end do
do j = 1, ilo
do i = 1, n
a( i, j ) = zero
end do
a( j, j ) = one
end do
do j = ihi + 1, n
do i = 1, n
a( i, j ) = zero
end do
a( j, j ) = one
end do
if( nh>0_${ik}$ ) then
! generate q(ilo+1:ihi,ilo+1:ihi)
call stdlib${ii}$_${ri}$orgqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, &
iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$orghr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sormhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, &
!! SORMHR overwrites the general real M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'T': Q**T * C C * Q**T
!! where Q is a real orthogonal matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! IHI-ILO elementary reflectors, as returned by SGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
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) :: side, trans
integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(sp), intent(inout) :: a(lda,*), c(ldc,*)
real(sp), intent(in) :: tau(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
left = stdlib_lsame( side, 'L' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) )&
then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then
info = -5_${ik}$
else if( ihi<min( ilo, nq ) .or. ihi>nq ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', side // trans, nh, n, nh, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', side // trans, m, nh, nh, -1_${ik}$ )
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORMHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nh==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = nh
ni = n
i1 = ilo + 1_${ik}$
i2 = 1_${ik}$
else
mi = m
ni = nh
i1 = 1_${ik}$
i2 = ilo + 1_${ik}$
end if
call stdlib${ii}$_sormqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, &
i2 ), ldc, work, lwork, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sormhr
pure module subroutine stdlib${ii}$_dormhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, &
!! DORMHR overwrites the general real M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'T': Q**T * C C * Q**T
!! where Q is a real orthogonal matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! IHI-ILO elementary reflectors, as returned by DGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
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) :: side, trans
integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(dp), intent(inout) :: a(lda,*), c(ldc,*)
real(dp), intent(in) :: tau(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
left = stdlib_lsame( side, 'L' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) )&
then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then
info = -5_${ik}$
else if( ihi<min( ilo, nq ) .or. ihi>nq ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', side // trans, nh, n, nh, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', side // trans, m, nh, nh, -1_${ik}$ )
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORMHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nh==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = nh
ni = n
i1 = ilo + 1_${ik}$
i2 = 1_${ik}$
else
mi = m
ni = nh
i1 = 1_${ik}$
i2 = ilo + 1_${ik}$
end if
call stdlib${ii}$_dormqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, &
i2 ), ldc, work, lwork, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dormhr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ormhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, &
!! DORMHR: overwrites the general real M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'T': Q**T * C C * Q**T
!! where Q is a real orthogonal matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! IHI-ILO elementary reflectors, as returned by DGEHRD:
!! Q = H(ilo) H(ilo+1) . . . H(ihi-1).
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) :: side, trans
integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n
integer(${ik}$), intent(out) :: info
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*)
real(${rk}$), intent(in) :: tau(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nh = ihi - ilo
left = stdlib_lsame( side, 'L' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) )&
then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then
info = -5_${ik}$
else if( ihi<min( ilo, nq ) .or. ihi>nq ) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', side // trans, nh, n, nh, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', side // trans, m, nh, nh, -1_${ik}$ )
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORMHR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nh==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = nh
ni = n
i1 = ilo + 1_${ik}$
i2 = 1_${ik}$
else
mi = m
ni = nh
i1 = 1_${ik}$
i2 = ilo + 1_${ik}$
end if
call stdlib${ii}$_${ri}$ormqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, &
i2 ), ldc, work, lwork, iinfo )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$ormhr
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_eigv_gen
