#:include "common.fypp"
submodule(stdlib_lapack_orthogonal_factors) stdlib_lapack_orthogonal_factors_ql
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_sgelq( m, n, a, lda, t, tsize, work, lwork,info )
!! SGELQ computes an LQ factorization of a real M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: t(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, lminws, mint, minw
integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ )
mint = .false.
minw = .false.
if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then
if( tsize/=-1_${ik}$ ) mint = .true.
if( lwork/=-1_${ik}$ ) minw = .true.
end if
! determine the block size
if( min( m, n )>0_${ik}$ ) then
mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ )
else
mb = 1_${ik}$
nb = n
end if
if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$
if( nb>n .or. nb<=m ) nb = n
mintsz = m + 5_${ik}$
if ( nb>m .and. n>m ) then
if( mod( n - m, nb - m )==0_${ik}$ ) then
nblcks = ( n - m ) / ( nb - m )
else
nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
! determine if the workspace size satisfies minimal size
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwmin = max( 1_${ik}$, n )
lwopt = max( 1_${ik}$, mb*n )
else
lwmin = max( 1_${ik}$, m )
lwopt = max( 1_${ik}$, mb*m )
end if
lminws = .false.
if( ( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) .or. lwork<lwopt ).and. ( lwork>=lwmin ) .and. ( &
tsize>=mintsz ).and. ( .not.lquery ) ) then
if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) ) then
lminws = .true.
mb = 1_${ik}$
nb = n
end if
if( lwork<lwopt ) then
lminws = .true.
mb = 1_${ik}$
end if
end if
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwreq = max( 1_${ik}$, mb*n )
else
lwreq = max( 1_${ik}$, mb*m )
end if
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) &
then
info = -6_${ik}$
else if( ( lwork<lwreq ) .and.( .not.lquery ).and. ( .not.lminws ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
if( mint ) then
t( 1_${ik}$ ) = mintsz
else
t( 1_${ik}$ ) = mb*m*nblcks + 5_${ik}$
end if
t( 2_${ik}$ ) = mb
t( 3_${ik}$ ) = nb
if( minw ) then
work( 1_${ik}$ ) = lwmin
else
work( 1_${ik}$ ) = lwreq
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGELQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n )==0_${ik}$ ) then
return
end if
! the lq decomposition
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
call stdlib${ii}$_sgelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info )
else
call stdlib${ii}$_slaswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwreq
return
end subroutine stdlib${ii}$_sgelq
pure module subroutine stdlib${ii}$_dgelq( m, n, a, lda, t, tsize, work, lwork,info )
!! DGELQ computes an LQ factorization of a real M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: t(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, lminws, mint, minw
integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ )
mint = .false.
minw = .false.
if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then
if( tsize/=-1_${ik}$ ) mint = .true.
if( lwork/=-1_${ik}$ ) minw = .true.
end if
! determine the block size
if( min( m, n )>0_${ik}$ ) then
mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ )
else
mb = 1_${ik}$
nb = n
end if
if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$
if( nb>n .or. nb<=m ) nb = n
mintsz = m + 5_${ik}$
if ( nb>m .and. n>m ) then
if( mod( n - m, nb - m )==0_${ik}$ ) then
nblcks = ( n - m ) / ( nb - m )
else
nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
! determine if the workspace size satisfies minimal size
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwmin = max( 1_${ik}$, n )
lwopt = max( 1_${ik}$, mb*n )
else
lwmin = max( 1_${ik}$, m )
lwopt = max( 1_${ik}$, mb*m )
end if
lminws = .false.
if( ( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) .or. lwork<lwopt ).and. ( lwork>=lwmin ) .and. ( &
tsize>=mintsz ).and. ( .not.lquery ) ) then
if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) ) then
lminws = .true.
mb = 1_${ik}$
nb = n
end if
if( lwork<lwopt ) then
lminws = .true.
mb = 1_${ik}$
end if
end if
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwreq = max( 1_${ik}$, mb*n )
else
lwreq = max( 1_${ik}$, mb*m )
end if
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) &
then
info = -6_${ik}$
else if( ( lwork<lwreq ) .and.( .not.lquery ).and. ( .not.lminws ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
if( mint ) then
t( 1_${ik}$ ) = mintsz
else
t( 1_${ik}$ ) = mb*m*nblcks + 5_${ik}$
end if
t( 2_${ik}$ ) = mb
t( 3_${ik}$ ) = nb
if( minw ) then
work( 1_${ik}$ ) = lwmin
else
work( 1_${ik}$ ) = lwreq
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n )==0_${ik}$ ) then
return
end if
! the lq decomposition
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
call stdlib${ii}$_dgelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info )
else
call stdlib${ii}$_dlaswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwreq
return
end subroutine stdlib${ii}$_dgelq
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gelq( m, n, a, lda, t, tsize, work, lwork,info )
!! DGELQ: computes an LQ factorization of a real M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: t(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, lminws, mint, minw
integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ )
mint = .false.
minw = .false.
if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then
if( tsize/=-1_${ik}$ ) mint = .true.
if( lwork/=-1_${ik}$ ) minw = .true.
end if
! determine the block size
if( min( m, n )>0_${ik}$ ) then
mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ )
else
mb = 1_${ik}$
nb = n
end if
if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$
if( nb>n .or. nb<=m ) nb = n
mintsz = m + 5_${ik}$
if ( nb>m .and. n>m ) then
if( mod( n - m, nb - m )==0_${ik}$ ) then
nblcks = ( n - m ) / ( nb - m )
else
nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
! determine if the workspace size satisfies minimal size
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwmin = max( 1_${ik}$, n )
lwopt = max( 1_${ik}$, mb*n )
else
lwmin = max( 1_${ik}$, m )
lwopt = max( 1_${ik}$, mb*m )
end if
lminws = .false.
if( ( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) .or. lwork<lwopt ).and. ( lwork>=lwmin ) .and. ( &
tsize>=mintsz ).and. ( .not.lquery ) ) then
if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) ) then
lminws = .true.
mb = 1_${ik}$
nb = n
end if
if( lwork<lwopt ) then
lminws = .true.
mb = 1_${ik}$
end if
end if
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwreq = max( 1_${ik}$, mb*n )
else
lwreq = max( 1_${ik}$, mb*m )
end if
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) &
then
info = -6_${ik}$
else if( ( lwork<lwreq ) .and.( .not.lquery ).and. ( .not.lminws ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
if( mint ) then
t( 1_${ik}$ ) = mintsz
else
t( 1_${ik}$ ) = mb*m*nblcks + 5_${ik}$
end if
t( 2_${ik}$ ) = mb
t( 3_${ik}$ ) = nb
if( minw ) then
work( 1_${ik}$ ) = lwmin
else
work( 1_${ik}$ ) = lwreq
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n )==0_${ik}$ ) then
return
end if
! the lq decomposition
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
call stdlib${ii}$_${ri}$gelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info )
else
call stdlib${ii}$_${ri}$laswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwreq
return
end subroutine stdlib${ii}$_${ri}$gelq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgelq( m, n, a, lda, t, tsize, work, lwork,info )
!! CGELQ computes an LQ factorization of a complex M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: t(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, lminws, mint, minw
integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ )
mint = .false.
minw = .false.
if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then
if( tsize/=-1_${ik}$ ) mint = .true.
if( lwork/=-1_${ik}$ ) minw = .true.
end if
! determine the block size
if( min( m, n )>0_${ik}$ ) then
mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ )
else
mb = 1_${ik}$
nb = n
end if
if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$
if( nb>n .or. nb<=m ) nb = n
mintsz = m + 5_${ik}$
if( nb>m .and. n>m ) then
if( mod( n - m, nb - m )==0_${ik}$ ) then
nblcks = ( n - m ) / ( nb - m )
else
nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
! determine if the workspace size satisfies minimal size
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwmin = max( 1_${ik}$, n )
lwopt = max( 1_${ik}$, mb*n )
else
lwmin = max( 1_${ik}$, m )
lwopt = max( 1_${ik}$, mb*m )
end if
lminws = .false.
if( ( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) .or. lwork<lwopt ).and. ( lwork>=lwmin ) .and. ( &
tsize>=mintsz ).and. ( .not.lquery ) ) then
if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) ) then
lminws = .true.
mb = 1_${ik}$
nb = n
end if
if( lwork<lwopt ) then
lminws = .true.
mb = 1_${ik}$
end if
end if
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwreq = max( 1_${ik}$, mb*n )
else
lwreq = max( 1_${ik}$, mb*m )
end if
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) &
then
info = -6_${ik}$
else if( ( lwork<lwreq ) .and.( .not.lquery ).and. ( .not.lminws ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
if( mint ) then
t( 1_${ik}$ ) = mintsz
else
t( 1_${ik}$ ) = mb*m*nblcks + 5_${ik}$
end if
t( 2_${ik}$ ) = mb
t( 3_${ik}$ ) = nb
if( minw ) then
work( 1_${ik}$ ) = lwmin
else
work( 1_${ik}$ ) = lwreq
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGELQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n )==0_${ik}$ ) then
return
end if
! the lq decomposition
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
call stdlib${ii}$_cgelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info )
else
call stdlib${ii}$_claswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwreq
return
end subroutine stdlib${ii}$_cgelq
pure module subroutine stdlib${ii}$_zgelq( m, n, a, lda, t, tsize, work, lwork,info )
!! ZGELQ computes an LQ factorization of a complex M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: t(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, lminws, mint, minw
integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ )
mint = .false.
minw = .false.
if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then
if( tsize/=-1_${ik}$ ) mint = .true.
if( lwork/=-1_${ik}$ ) minw = .true.
end if
! determine the block size
if( min( m, n )>0_${ik}$ ) then
mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ )
else
mb = 1_${ik}$
nb = n
end if
if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$
if( nb>n .or. nb<=m ) nb = n
mintsz = m + 5_${ik}$
if ( nb>m .and. n>m ) then
if( mod( n - m, nb - m )==0_${ik}$ ) then
nblcks = ( n - m ) / ( nb - m )
else
nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
! determine if the workspace size satisfies minimal size
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwmin = max( 1_${ik}$, n )
lwopt = max( 1_${ik}$, mb*n )
else
lwmin = max( 1_${ik}$, m )
lwopt = max( 1_${ik}$, mb*m )
end if
lminws = .false.
if( ( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) .or. lwork<lwopt ).and. ( lwork>=lwmin ) .and. ( &
tsize>=mintsz ).and. ( .not.lquery ) ) then
if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) ) then
lminws = .true.
mb = 1_${ik}$
nb = n
end if
if( lwork<lwopt ) then
lminws = .true.
mb = 1_${ik}$
end if
end if
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwreq = max( 1_${ik}$, mb*n )
else
lwreq = max( 1_${ik}$, mb*m )
end if
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) &
then
info = -6_${ik}$
else if( ( lwork<lwreq ) .and.( .not.lquery ).and. ( .not.lminws ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
if( mint ) then
t( 1_${ik}$ ) = mintsz
else
t( 1_${ik}$ ) = mb*m*nblcks + 5_${ik}$
end if
t( 2_${ik}$ ) = mb
t( 3_${ik}$ ) = nb
if( minw ) then
work( 1_${ik}$ ) = lwmin
else
work( 1_${ik}$ ) = lwreq
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n )==0_${ik}$ ) then
return
end if
! the lq decomposition
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
call stdlib${ii}$_zgelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info )
else
call stdlib${ii}$_zlaswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwreq
return
end subroutine stdlib${ii}$_zgelq
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gelq( m, n, a, lda, t, tsize, work, lwork,info )
!! ZGELQ: computes an LQ factorization of a complex M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: t(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, lminws, mint, minw
integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ )
mint = .false.
minw = .false.
if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then
if( tsize/=-1_${ik}$ ) mint = .true.
if( lwork/=-1_${ik}$ ) minw = .true.
end if
! determine the block size
if( min( m, n )>0_${ik}$ ) then
mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ )
else
mb = 1_${ik}$
nb = n
end if
if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$
if( nb>n .or. nb<=m ) nb = n
mintsz = m + 5_${ik}$
if ( nb>m .and. n>m ) then
if( mod( n - m, nb - m )==0_${ik}$ ) then
nblcks = ( n - m ) / ( nb - m )
else
nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
! determine if the workspace size satisfies minimal size
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwmin = max( 1_${ik}$, n )
lwopt = max( 1_${ik}$, mb*n )
else
lwmin = max( 1_${ik}$, m )
lwopt = max( 1_${ik}$, mb*m )
end if
lminws = .false.
if( ( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) .or. lwork<lwopt ).and. ( lwork>=lwmin ) .and. ( &
tsize>=mintsz ).and. ( .not.lquery ) ) then
if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ) ) then
lminws = .true.
mb = 1_${ik}$
nb = n
end if
if( lwork<lwopt ) then
lminws = .true.
mb = 1_${ik}$
end if
end if
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
lwreq = max( 1_${ik}$, mb*n )
else
lwreq = max( 1_${ik}$, mb*m )
end if
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( tsize<max( 1_${ik}$, mb*m*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) &
then
info = -6_${ik}$
else if( ( lwork<lwreq ) .and.( .not.lquery ).and. ( .not.lminws ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
if( mint ) then
t( 1_${ik}$ ) = mintsz
else
t( 1_${ik}$ ) = mb*m*nblcks + 5_${ik}$
end if
t( 2_${ik}$ ) = mb
t( 3_${ik}$ ) = nb
if( minw ) then
work( 1_${ik}$ ) = lwmin
else
work( 1_${ik}$ ) = lwreq
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n )==0_${ik}$ ) then
return
end if
! the lq decomposition
if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then
call stdlib${ii}$_${ci}$gelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info )
else
call stdlib${ii}$_${ci}$laswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwreq
return
end subroutine stdlib${ii}$_${ci}$gelq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, &
!! SGEMLQ 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 defined as the product
!! of blocked elementary reflectors computed by short wide LQ
!! factorization (SGELQ)
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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc
! Array Arguments
real(sp), intent(in) :: a(lda,*), t(*)
real(sp), intent(inout) :: c(ldc,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: mb, nb, lw, nblcks, mn
! Intrinsic Functions
! Executable Statements
! test the input arguments
lquery = lwork==-1_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'T' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
mb = int( t( 2_${ik}$ ),KIND=${ik}$)
nb = int( t( 3_${ik}$ ),KIND=${ik}$)
if( left ) then
lw = n * mb
mn = m
else
lw = m * mb
mn = n
end if
if( ( nb>k ) .and. ( mn>k ) ) then
if( mod( mn - k, nb - k ) == 0_${ik}$ ) then
nblcks = ( mn - k ) / ( nb - k )
else
nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>mn ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( tsize<5_${ik}$ ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( ( lwork<max( 1_${ik}$, lw ) ) .and. ( .not.lquery ) ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = real( lw,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n, k )==0_${ik}$ ) then
return
end if
if( ( left .and. m<=k ) .or. ( right .and. n<=k ).or. ( nb<=k ) .or. ( nb>=max( m, n, &
k ) ) ) then
call stdlib${ii}$_sgemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info &
)
else
call stdlib${ii}$_slamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, &
lwork, info )
end if
work( 1_${ik}$ ) = real( lw,KIND=sp)
return
end subroutine stdlib${ii}$_sgemlq
pure module subroutine stdlib${ii}$_dgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, &
!! DGEMLQ 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 defined as the product
!! of blocked elementary reflectors computed by short wide LQ
!! factorization (DGELQ)
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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc
! Array Arguments
real(dp), intent(in) :: a(lda,*), t(*)
real(dp), intent(inout) :: c(ldc,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: mb, nb, lw, nblcks, mn
! Intrinsic Functions
! Executable Statements
! test the input arguments
lquery = lwork==-1_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'T' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
mb = int( t( 2_${ik}$ ),KIND=${ik}$)
nb = int( t( 3_${ik}$ ),KIND=${ik}$)
if( left ) then
lw = n * mb
mn = m
else
lw = m * mb
mn = n
end if
if( ( nb>k ) .and. ( mn>k ) ) then
if( mod( mn - k, nb - k ) == 0_${ik}$ ) then
nblcks = ( mn - k ) / ( nb - k )
else
nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>mn ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( tsize<5_${ik}$ ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( ( lwork<max( 1_${ik}$, lw ) ) .and. ( .not.lquery ) ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lw
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n, k )==0_${ik}$ ) then
return
end if
if( ( left .and. m<=k ) .or. ( right .and. n<=k ).or. ( nb<=k ) .or. ( nb>=max( m, n, &
k ) ) ) then
call stdlib${ii}$_dgemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info &
)
else
call stdlib${ii}$_dlamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, &
lwork, info )
end if
work( 1_${ik}$ ) = lw
return
end subroutine stdlib${ii}$_dgemlq
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, &
!! DGEMLQ: 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 defined as the product
!! of blocked elementary reflectors computed by short wide LQ
!! factorization (DGELQ)
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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), t(*)
real(${rk}$), intent(inout) :: c(ldc,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: mb, nb, lw, nblcks, mn
! Intrinsic Functions
! Executable Statements
! test the input arguments
lquery = lwork==-1_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'T' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
mb = int( t( 2_${ik}$ ),KIND=${ik}$)
nb = int( t( 3_${ik}$ ),KIND=${ik}$)
if( left ) then
lw = n * mb
mn = m
else
lw = m * mb
mn = n
end if
if( ( nb>k ) .and. ( mn>k ) ) then
if( mod( mn - k, nb - k ) == 0_${ik}$ ) then
nblcks = ( mn - k ) / ( nb - k )
else
nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>mn ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( tsize<5_${ik}$ ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( ( lwork<max( 1_${ik}$, lw ) ) .and. ( .not.lquery ) ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lw
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n, k )==0_${ik}$ ) then
return
end if
if( ( left .and. m<=k ) .or. ( right .and. n<=k ).or. ( nb<=k ) .or. ( nb>=max( m, n, &
k ) ) ) then
call stdlib${ii}$_${ri}$gemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info &
)
else
call stdlib${ii}$_${ri}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, &
lwork, info )
end if
work( 1_${ik}$ ) = lw
return
end subroutine stdlib${ii}$_${ri}$gemlq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, &
!! CGEMLQ overwrites the general real 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 defined as the product
!! of blocked elementary reflectors computed by short wide
!! LQ factorization (CGELQ)
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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc
! Array Arguments
complex(sp), intent(in) :: a(lda,*), t(*)
complex(sp), intent(inout) :: c(ldc,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: mb, nb, lw, nblcks, mn
! Intrinsic Functions
! Executable Statements
! test the input arguments
lquery = lwork==-1_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'C' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
mb = int( t( 2_${ik}$ ),KIND=${ik}$)
nb = int( t( 3_${ik}$ ),KIND=${ik}$)
if( left ) then
lw = n * mb
mn = m
else
lw = m * mb
mn = n
end if
if( ( nb>k ) .and. ( mn>k ) ) then
if( mod( mn - k, nb - k ) == 0_${ik}$ ) then
nblcks = ( mn - k ) / ( nb - k )
else
nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>mn ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( tsize<5_${ik}$ ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( ( lwork<max( 1_${ik}$, lw ) ) .and. ( .not.lquery ) ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = real( lw,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n, k )==0_${ik}$ ) then
return
end if
if( ( left .and. m<=k ) .or. ( right .and. n<=k ).or. ( nb<=k ) .or. ( nb>=max( m, n, &
k ) ) ) then
call stdlib${ii}$_cgemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info &
)
else
call stdlib${ii}$_clamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, &
lwork, info )
end if
work( 1_${ik}$ ) = real( lw,KIND=sp)
return
end subroutine stdlib${ii}$_cgemlq
pure module subroutine stdlib${ii}$_zgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, &
!! ZGEMLQ overwrites the general real 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 defined as the product
!! of blocked elementary reflectors computed by short wide
!! LQ factorization (ZGELQ)
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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc
! Array Arguments
complex(dp), intent(in) :: a(lda,*), t(*)
complex(dp), intent(inout) :: c(ldc,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: mb, nb, lw, nblcks, mn
! Intrinsic Functions
! Executable Statements
! test the input arguments
lquery = lwork==-1_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'C' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
mb = int( t( 2_${ik}$ ),KIND=${ik}$)
nb = int( t( 3_${ik}$ ),KIND=${ik}$)
if( left ) then
lw = n * mb
mn = m
else
lw = m * mb
mn = n
end if
if( ( nb>k ) .and. ( mn>k ) ) then
if( mod( mn - k, nb - k ) == 0_${ik}$ ) then
nblcks = ( mn - k ) / ( nb - k )
else
nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>mn ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( tsize<5_${ik}$ ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( ( lwork<max( 1_${ik}$, lw ) ) .and. ( .not.lquery ) ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lw
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n, k )==0_${ik}$ ) then
return
end if
if( ( left .and. m<=k ) .or. ( right .and. n<=k ).or. ( nb<=k ) .or. ( nb>=max( m, n, &
k ) ) ) then
call stdlib${ii}$_zgemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info &
)
else
call stdlib${ii}$_zlamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, &
lwork, info )
end if
work( 1_${ik}$ ) = lw
return
end subroutine stdlib${ii}$_zgemlq
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, &
!! ZGEMLQ: overwrites the general real 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 defined as the product
!! of blocked elementary reflectors computed by short wide
!! LQ factorization (ZGELQ)
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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), t(*)
complex(${ck}$), intent(inout) :: c(ldc,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: mb, nb, lw, nblcks, mn
! Intrinsic Functions
! Executable Statements
! test the input arguments
lquery = lwork==-1_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'C' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
mb = int( t( 2_${ik}$ ),KIND=${ik}$)
nb = int( t( 3_${ik}$ ),KIND=${ik}$)
if( left ) then
lw = n * mb
mn = m
else
lw = m * mb
mn = n
end if
if( ( nb>k ) .and. ( mn>k ) ) then
if( mod( mn - k, nb - k ) == 0_${ik}$ ) then
nblcks = ( mn - k ) / ( nb - k )
else
nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$
end if
else
nblcks = 1_${ik}$
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>mn ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( tsize<5_${ik}$ ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
else if( ( lwork<max( 1_${ik}$, lw ) ) .and. ( .not.lquery ) ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lw
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( min( m, n, k )==0_${ik}$ ) then
return
end if
if( ( left .and. m<=k ) .or. ( right .and. n<=k ).or. ( nb<=k ) .or. ( nb>=max( m, n, &
k ) ) ) then
call stdlib${ii}$_${ci}$gemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info &
)
else
call stdlib${ii}$_${ci}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, &
lwork, info )
end if
work( 1_${ik}$ ) = lw
return
end subroutine stdlib${ii}$_${ci}$gemlq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgelqf( m, n, a, lda, tau, work, lwork, info )
!! SGELQF computes an LQ factorization of a real M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = m*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGELQF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
k = min( m, n )
if( k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'SGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially
do i = 1, k - nx, nb
ib = min( k-i+1, nb )
! compute the lq factorization of the current block
! a(i:i+ib-1,i:n)
call stdlib${ii}$_sgelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_slarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_slarfb( 'RIGHT', 'NO TRANSPOSE', 'FORWARD','ROWWISE', m-i-ib+1, n-&
i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), ldwork )
end if
end do
else
i = 1_${ik}$
end if
! use unblocked code to factor the last or only block.
if( i<=k )call stdlib${ii}$_sgelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_sgelqf
pure module subroutine stdlib${ii}$_dgelqf( m, n, a, lda, tau, work, lwork, info )
!! DGELQF computes an LQ factorization of a real M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = m*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
k = min( m, n )
if( k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially
do i = 1, k - nx, nb
ib = min( k-i+1, nb )
! compute the lq factorization of the current block
! a(i:i+ib-1,i:n)
call stdlib${ii}$_dgelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_dlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_dlarfb( 'RIGHT', 'NO TRANSPOSE', 'FORWARD','ROWWISE', m-i-ib+1, n-&
i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), ldwork )
end if
end do
else
i = 1_${ik}$
end if
! use unblocked code to factor the last or only block.
if( i<=k )call stdlib${ii}$_dgelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_dgelqf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gelqf( m, n, a, lda, tau, work, lwork, info )
!! DGELQF: computes an LQ factorization of a real M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = m*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
k = min( m, n )
if( k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially
do i = 1, k - nx, nb
ib = min( k-i+1, nb )
! compute the lq factorization of the current block
! a(i:i+ib-1,i:n)
call stdlib${ii}$_${ri}$gelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_${ri}$larft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_${ri}$larfb( 'RIGHT', 'NO TRANSPOSE', 'FORWARD','ROWWISE', m-i-ib+1, n-&
i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), ldwork )
end if
end do
else
i = 1_${ik}$
end if
! use unblocked code to factor the last or only block.
if( i<=k )call stdlib${ii}$_${ri}$gelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ri}$gelqf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgelqf( m, n, a, lda, tau, work, lwork, info )
!! CGELQF computes an LQ factorization of a complex M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = m*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGELQF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
k = min( m, n )
if( k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'CGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially
do i = 1, k - nx, nb
ib = min( k-i+1, nb )
! compute the lq factorization of the current block
! a(i:i+ib-1,i:n)
call stdlib${ii}$_cgelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_clarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_clarfb( 'RIGHT', 'NO TRANSPOSE', 'FORWARD','ROWWISE', m-i-ib+1, n-&
i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), ldwork )
end if
end do
else
i = 1_${ik}$
end if
! use unblocked code to factor the last or only block.
if( i<=k )call stdlib${ii}$_cgelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_cgelqf
pure module subroutine stdlib${ii}$_zgelqf( m, n, a, lda, tau, work, lwork, info )
!! ZGELQF computes an LQ factorization of a complex M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = m*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
k = min( m, n )
if( k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially
do i = 1, k - nx, nb
ib = min( k-i+1, nb )
! compute the lq factorization of the current block
! a(i:i+ib-1,i:n)
call stdlib${ii}$_zgelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_zlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_zlarfb( 'RIGHT', 'NO TRANSPOSE', 'FORWARD','ROWWISE', m-i-ib+1, n-&
i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), ldwork )
end if
end do
else
i = 1_${ik}$
end if
! use unblocked code to factor the last or only block.
if( i<=k )call stdlib${ii}$_zgelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_zgelqf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gelqf( m, n, a, lda, tau, work, lwork, info )
!! ZGELQF: computes an LQ factorization of a complex M-by-N matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a N-by-N orthogonal matrix;
!! L is a lower-triangular M-by-M matrix;
!! 0 is a M-by-(N-M) zero matrix, if M < N.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = m*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
k = min( m, n )
if( k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially
do i = 1, k - nx, nb
ib = min( k-i+1, nb )
! compute the lq factorization of the current block
! a(i:i+ib-1,i:n)
call stdlib${ii}$_${ci}$gelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_${ci}$larft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_${ci}$larfb( 'RIGHT', 'NO TRANSPOSE', 'FORWARD','ROWWISE', m-i-ib+1, n-&
i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), ldwork )
end if
end do
else
i = 1_${ik}$
end if
! use unblocked code to factor the last or only block.
if( i<=k )call stdlib${ii}$_${ci}$gelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ci}$gelqf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgelq2( m, n, a, lda, tau, work, info )
!! SGELQ2 computes an LQ factorization of a real m-by-n matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a n-by-n orthogonal matrix;
!! L is a lower-triangular m-by-m matrix;
!! 0 is a m-by-(n-m) zero matrix, if m < n.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
real(sp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGELQ2', -info )
return
end if
k = min( m, n )
do i = 1, k
! generate elementary reflector h(i) to annihilate a(i,i+1:n)
call stdlib${ii}$_slarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,tau( i ) )
if( i<m ) then
! apply h(i) to a(i+1:m,i:n) from the right
aii = a( i, i )
a( i, i ) = one
call stdlib${ii}$_slarf( 'RIGHT', m-i, n-i+1, a( i, i ), lda, tau( i ),a( i+1, i ), &
lda, work )
a( i, i ) = aii
end if
end do
return
end subroutine stdlib${ii}$_sgelq2
pure module subroutine stdlib${ii}$_dgelq2( m, n, a, lda, tau, work, info )
!! DGELQ2 computes an LQ factorization of a real m-by-n matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a n-by-n orthogonal matrix;
!! L is a lower-triangular m-by-m matrix;
!! 0 is a m-by-(n-m) zero matrix, if m < n.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
real(dp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQ2', -info )
return
end if
k = min( m, n )
do i = 1, k
! generate elementary reflector h(i) to annihilate a(i,i+1:n)
call stdlib${ii}$_dlarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,tau( i ) )
if( i<m ) then
! apply h(i) to a(i+1:m,i:n) from the right
aii = a( i, i )
a( i, i ) = one
call stdlib${ii}$_dlarf( 'RIGHT', m-i, n-i+1, a( i, i ), lda, tau( i ),a( i+1, i ), &
lda, work )
a( i, i ) = aii
end if
end do
return
end subroutine stdlib${ii}$_dgelq2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gelq2( m, n, a, lda, tau, work, info )
!! DGELQ2: computes an LQ factorization of a real m-by-n matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a n-by-n orthogonal matrix;
!! L is a lower-triangular m-by-m matrix;
!! 0 is a m-by-(n-m) zero matrix, if m < n.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
real(${rk}$) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQ2', -info )
return
end if
k = min( m, n )
do i = 1, k
! generate elementary reflector h(i) to annihilate a(i,i+1:n)
call stdlib${ii}$_${ri}$larfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,tau( i ) )
if( i<m ) then
! apply h(i) to a(i+1:m,i:n) from the right
aii = a( i, i )
a( i, i ) = one
call stdlib${ii}$_${ri}$larf( 'RIGHT', m-i, n-i+1, a( i, i ), lda, tau( i ),a( i+1, i ), &
lda, work )
a( i, i ) = aii
end if
end do
return
end subroutine stdlib${ii}$_${ri}$gelq2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgelq2( m, n, a, lda, tau, work, info )
!! CGELQ2 computes an LQ factorization of a complex m-by-n matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a n-by-n orthogonal matrix;
!! L is a lower-triangular m-by-m matrix;
!! 0 is a m-by-(n-m) zero matrix, if m < n.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
complex(sp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGELQ2', -info )
return
end if
k = min( m, n )
do i = 1, k
! generate elementary reflector h(i) to annihilate a(i,i+1:n)
call stdlib${ii}$_clacgv( n-i+1, a( i, i ), lda )
alpha = a( i, i )
call stdlib${ii}$_clarfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,tau( i ) )
if( i<m ) then
! apply h(i) to a(i+1:m,i:n) from the right
a( i, i ) = cone
call stdlib${ii}$_clarf( 'RIGHT', m-i, n-i+1, a( i, i ), lda, tau( i ),a( i+1, i ), &
lda, work )
end if
a( i, i ) = alpha
call stdlib${ii}$_clacgv( n-i+1, a( i, i ), lda )
end do
return
end subroutine stdlib${ii}$_cgelq2
pure module subroutine stdlib${ii}$_zgelq2( m, n, a, lda, tau, work, info )
!! ZGELQ2 computes an LQ factorization of a complex m-by-n matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a n-by-n orthogonal matrix;
!! L is a lower-triangular m-by-m matrix;
!! 0 is a m-by-(n-m) zero matrix, if m < n.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
complex(dp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQ2', -info )
return
end if
k = min( m, n )
do i = 1, k
! generate elementary reflector h(i) to annihilate a(i,i+1:n)
call stdlib${ii}$_zlacgv( n-i+1, a( i, i ), lda )
alpha = a( i, i )
call stdlib${ii}$_zlarfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,tau( i ) )
if( i<m ) then
! apply h(i) to a(i+1:m,i:n) from the right
a( i, i ) = cone
call stdlib${ii}$_zlarf( 'RIGHT', m-i, n-i+1, a( i, i ), lda, tau( i ),a( i+1, i ), &
lda, work )
end if
a( i, i ) = alpha
call stdlib${ii}$_zlacgv( n-i+1, a( i, i ), lda )
end do
return
end subroutine stdlib${ii}$_zgelq2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gelq2( m, n, a, lda, tau, work, info )
!! ZGELQ2: computes an LQ factorization of a complex m-by-n matrix A:
!! A = ( L 0 ) * Q
!! where:
!! Q is a n-by-n orthogonal matrix;
!! L is a lower-triangular m-by-m matrix;
!! 0 is a m-by-(n-m) zero matrix, if m < n.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
complex(${ck}$) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQ2', -info )
return
end if
k = min( m, n )
do i = 1, k
! generate elementary reflector h(i) to annihilate a(i,i+1:n)
call stdlib${ii}$_${ci}$lacgv( n-i+1, a( i, i ), lda )
alpha = a( i, i )
call stdlib${ii}$_${ci}$larfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,tau( i ) )
if( i<m ) then
! apply h(i) to a(i+1:m,i:n) from the right
a( i, i ) = cone
call stdlib${ii}$_${ci}$larf( 'RIGHT', m-i, n-i+1, a( i, i ), lda, tau( i ),a( i+1, i ), &
lda, work )
end if
a( i, i ) = alpha
call stdlib${ii}$_${ci}$lacgv( n-i+1, a( i, i ), lda )
end do
return
end subroutine stdlib${ii}$_${ci}$gelq2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunglq( m, n, k, a, lda, tau, work, lwork, info )
!! CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
!! which is defined as the first M rows of a product of K elementary
!! reflectors of order N
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by CGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGLQ', ' ', m, n, k, -1_${ik}$ )
lwkopt = max( 1_${ik}$, m )*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNGLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m<=0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'CUNGLQ', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CUNGLQ', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the last block.
! the first kk rows are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
! set a(kk+1:m,1:kk) to czero.
do j = 1, kk
do i = kk + 1, m
a( i, j ) = czero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the last or only block.
if( kk<m )call stdlib${ii}$_cungl2( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,tau( kk+1 ), work,&
iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = ki + 1, 1, -nb
ib = min( nb, k-i+1 )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_clarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h**h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_clarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-&
ib+1, n-i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), &
ldwork )
end if
! apply h**h to columns i:n of current block
call stdlib${ii}$_cungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo )
! set columns 1:i-1 of current block to czero
do j = 1, i - 1
do l = i, i + ib - 1
a( l, j ) = czero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_cunglq
pure module subroutine stdlib${ii}$_zunglq( m, n, k, a, lda, tau, work, lwork, info )
!! ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
!! which is defined as the first M rows of a product of K elementary
!! reflectors of order N
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by ZGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGLQ', ' ', m, n, k, -1_${ik}$ )
lwkopt = max( 1_${ik}$, m )*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m<=0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZUNGLQ', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZUNGLQ', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the last block.
! the first kk rows are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
! set a(kk+1:m,1:kk) to czero.
do j = 1, kk
do i = kk + 1, m
a( i, j ) = czero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the last or only block.
if( kk<m )call stdlib${ii}$_zungl2( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,tau( kk+1 ), work,&
iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = ki + 1, 1, -nb
ib = min( nb, k-i+1 )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_zlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h**h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_zlarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-&
ib+1, n-i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), &
ldwork )
end if
! apply h**h to columns i:n of current block
call stdlib${ii}$_zungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo )
! set columns 1:i-1 of current block to czero
do j = 1, i - 1
do l = i, i + ib - 1
a( l, j ) = czero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_zunglq
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unglq( m, n, k, a, lda, tau, work, lwork, info )
!! ZUNGLQ: generates an M-by-N complex matrix Q with orthonormal rows,
!! which is defined as the first M rows of a product of K elementary
!! reflectors of order N
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by ZGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGLQ', ' ', m, n, k, -1_${ik}$ )
lwkopt = max( 1_${ik}$, m )*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m<=0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZUNGLQ', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZUNGLQ', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the last block.
! the first kk rows are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
! set a(kk+1:m,1:kk) to czero.
do j = 1, kk
do i = kk + 1, m
a( i, j ) = czero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the last or only block.
if( kk<m )call stdlib${ii}$_${ci}$ungl2( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,tau( kk+1 ), work,&
iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = ki + 1, 1, -nb
ib = min( nb, k-i+1 )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_${ci}$larft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h**h to a(i+ib:m,i:n) from the right
call stdlib${ii}$_${ci}$larfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-&
ib+1, n-i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), &
ldwork )
end if
! apply h**h to columns i:n of current block
call stdlib${ii}$_${ci}$ungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo )
! set columns 1:i-1 of current block to czero
do j = 1, i - 1
do l = i, i + ib - 1
a( l, j ) = czero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ci}$unglq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cungl2( m, n, k, a, lda, tau, work, info )
!! CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
!! which is defined as the first m rows of a product of k elementary
!! reflectors of order n
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by CGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(in) :: tau(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNGL2', -info )
return
end if
! quick return if possible
if( m<=0 )return
if( k<m ) then
! initialise rows k+1:m to rows of the unit matrix
do j = 1, n
do l = k + 1, m
a( l, j ) = czero
end do
if( j>k .and. j<=m )a( j, j ) = cone
end do
end if
do i = k, 1, -1
! apply h(i)**h to a(i:m,i:n) from the right
if( i<n ) then
call stdlib${ii}$_clacgv( n-i, a( i, i+1 ), lda )
if( i<m ) then
a( i, i ) = cone
call stdlib${ii}$_clarf( 'RIGHT', m-i, n-i+1, a( i, i ), lda,conjg( tau( i ) ), a( &
i+1, i ), lda, work )
end if
call stdlib${ii}$_cscal( n-i, -tau( i ), a( i, i+1 ), lda )
call stdlib${ii}$_clacgv( n-i, a( i, i+1 ), lda )
end if
a( i, i ) = cone - conjg( tau( i ) )
! set a(i,1:i-1,i) to czero
do l = 1, i - 1
a( i, l ) = czero
end do
end do
return
end subroutine stdlib${ii}$_cungl2
pure module subroutine stdlib${ii}$_zungl2( m, n, k, a, lda, tau, work, info )
!! ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
!! which is defined as the first m rows of a product of k elementary
!! reflectors of order n
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by ZGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(in) :: tau(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGL2', -info )
return
end if
! quick return if possible
if( m<=0 )return
if( k<m ) then
! initialise rows k+1:m to rows of the unit matrix
do j = 1, n
do l = k + 1, m
a( l, j ) = czero
end do
if( j>k .and. j<=m )a( j, j ) = cone
end do
end if
do i = k, 1, -1
! apply h(i)**h to a(i:m,i:n) from the right
if( i<n ) then
call stdlib${ii}$_zlacgv( n-i, a( i, i+1 ), lda )
if( i<m ) then
a( i, i ) = cone
call stdlib${ii}$_zlarf( 'RIGHT', m-i, n-i+1, a( i, i ), lda,conjg( tau( i ) ), a( &
i+1, i ), lda, work )
end if
call stdlib${ii}$_zscal( n-i, -tau( i ), a( i, i+1 ), lda )
call stdlib${ii}$_zlacgv( n-i, a( i, i+1 ), lda )
end if
a( i, i ) = cone - conjg( tau( i ) )
! set a(i,1:i-1) to czero
do l = 1, i - 1
a( i, l ) = czero
end do
end do
return
end subroutine stdlib${ii}$_zungl2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ungl2( m, n, k, a, lda, tau, work, info )
!! ZUNGL2: generates an m-by-n complex matrix Q with orthonormal rows,
!! which is defined as the first m rows of a product of k elementary
!! reflectors of order n
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by ZGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(in) :: tau(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGL2', -info )
return
end if
! quick return if possible
if( m<=0 )return
if( k<m ) then
! initialise rows k+1:m to rows of the unit matrix
do j = 1, n
do l = k + 1, m
a( l, j ) = czero
end do
if( j>k .and. j<=m )a( j, j ) = cone
end do
end if
do i = k, 1, -1
! apply h(i)**h to a(i:m,i:n) from the right
if( i<n ) then
call stdlib${ii}$_${ci}$lacgv( n-i, a( i, i+1 ), lda )
if( i<m ) then
a( i, i ) = cone
call stdlib${ii}$_${ci}$larf( 'RIGHT', m-i, n-i+1, a( i, i ), lda,conjg( tau( i ) ), a( &
i+1, i ), lda, work )
end if
call stdlib${ii}$_${ci}$scal( n-i, -tau( i ), a( i, i+1 ), lda )
call stdlib${ii}$_${ci}$lacgv( n-i, a( i, i+1 ), lda )
end if
a( i, i ) = cone - conjg( tau( i ) )
! set a(i,1:i-1) to czero
do l = 1, i - 1
a( i, l ) = czero
end do
end do
return
end subroutine stdlib${ii}$_${ci}$ungl2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunmlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! CUNMLQ 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 defined as the product of k
!! elementary reflectors
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*), c(ldc,*)
complex(sp), intent(in) :: tau(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
character :: transt
integer(${ik}$) :: i, i1, i2, i3, ib, ic, iinfo, iwt, jc, ldwork, lwkopt, mi, nb, nbmin, &
ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
if( m==0_${ik}$ .or. n==0_${ik}$ .or. k==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMLQ', side // trans, m, n,k, -1_${ik}$ ) )
lwkopt = nw*nb + tsize
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. k==0_${ik}$ ) then
return
end if
! determine the block size
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CUNMLQ', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_cunml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
if( notran ) then
transt = 'C'
else
transt = 'N'
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_clarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), &
work( iwt ), ldt )
if( left ) then
! h or h**h is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h or h**h is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h or h**h
call stdlib${ii}$_clarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), &
lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cunmlq
pure module subroutine stdlib${ii}$_zunmlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! ZUNMLQ 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 defined as the product of k
!! elementary reflectors
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*), c(ldc,*)
complex(dp), intent(in) :: tau(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
character :: transt
integer(${ik}$) :: i, i1, i2, i3, ib, ic, iinfo, iwt, jc, ldwork, lwkopt, mi, nb, nbmin, &
ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', side // trans, m, n, k,-1_${ik}$ ) )
lwkopt = nw*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZUNMLQ', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_zunml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
if( notran ) then
transt = 'C'
else
transt = 'N'
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_zlarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), &
work( iwt ), ldt )
if( left ) then
! h or h**h is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h or h**h is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h or h**h
call stdlib${ii}$_zlarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), &
lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zunmlq
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unmlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! ZUNMLQ: 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 defined as the product of k
!! elementary reflectors
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*)
complex(${ck}$), intent(in) :: tau(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
character :: transt
integer(${ik}$) :: i, i1, i2, i3, ib, ic, iinfo, iwt, jc, ldwork, lwkopt, mi, nb, nbmin, &
ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', side // trans, m, n, k,-1_${ik}$ ) )
lwkopt = nw*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZUNMLQ', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_${ci}$unml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
if( notran ) then
transt = 'C'
else
transt = 'N'
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_${ci}$larft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), &
work( iwt ), ldt )
if( left ) then
! h or h**h is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h or h**h is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h or h**h
call stdlib${ii}$_${ci}$larfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), &
lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$unmlq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! CUNML2 overwrites the general complex m-by-n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**H* C if SIDE = 'L' and TRANS = 'C', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**H if SIDE = 'R' and TRANS = 'C',
!! where Q is a complex unitary matrix defined as the product of k
!! elementary reflectors
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, ic, jc, mi, ni, nq
complex(sp) :: aii, taui
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNML2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran .or. .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
do i = i1, i2, i3
if( left ) then
! h(i) or h(i)**h is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h(i) or h(i)**h is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h(i) or h(i)**h
if( notran ) then
taui = conjg( tau( i ) )
else
taui = tau( i )
end if
if( i<nq )call stdlib${ii}$_clacgv( nq-i, a( i, i+1 ), lda )
aii = a( i, i )
a( i, i ) = cone
call stdlib${ii}$_clarf( side, mi, ni, a( i, i ), lda, taui, c( ic, jc ),ldc, work )
a( i, i ) = aii
if( i<nq )call stdlib${ii}$_clacgv( nq-i, a( i, i+1 ), lda )
end do
return
end subroutine stdlib${ii}$_cunml2
pure module subroutine stdlib${ii}$_zunml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! ZUNML2 overwrites the general complex m-by-n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**H* C if SIDE = 'L' and TRANS = 'C', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**H if SIDE = 'R' and TRANS = 'C',
!! where Q is a complex unitary matrix defined as the product of k
!! elementary reflectors
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, ic, jc, mi, ni, nq
complex(dp) :: aii, taui
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNML2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran .or. .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
do i = i1, i2, i3
if( left ) then
! h(i) or h(i)**h is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h(i) or h(i)**h is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h(i) or h(i)**h
if( notran ) then
taui = conjg( tau( i ) )
else
taui = tau( i )
end if
if( i<nq )call stdlib${ii}$_zlacgv( nq-i, a( i, i+1 ), lda )
aii = a( i, i )
a( i, i ) = cone
call stdlib${ii}$_zlarf( side, mi, ni, a( i, i ), lda, taui, c( ic, jc ),ldc, work )
a( i, i ) = aii
if( i<nq )call stdlib${ii}$_zlacgv( nq-i, a( i, i+1 ), lda )
end do
return
end subroutine stdlib${ii}$_zunml2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! ZUNML2: overwrites the general complex m-by-n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**H* C if SIDE = 'L' and TRANS = 'C', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**H if SIDE = 'R' and TRANS = 'C',
!! where Q is a complex unitary matrix defined as the product of k
!! elementary reflectors
!! Q = H(k)**H . . . H(2)**H H(1)**H
!! as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, ic, jc, mi, ni, nq
complex(${ck}$) :: aii, taui
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNML2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran .or. .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
do i = i1, i2, i3
if( left ) then
! h(i) or h(i)**h is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h(i) or h(i)**h is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h(i) or h(i)**h
if( notran ) then
taui = conjg( tau( i ) )
else
taui = tau( i )
end if
if( i<nq )call stdlib${ii}$_${ci}$lacgv( nq-i, a( i, i+1 ), lda )
aii = a( i, i )
a( i, i ) = cone
call stdlib${ii}$_${ci}$larf( side, mi, ni, a( i, i ), lda, taui, c( ic, jc ),ldc, work )
a( i, i ) = aii
if( i<nq )call stdlib${ii}$_${ci}$lacgv( nq-i, a( i, i+1 ), lda )
end do
return
end subroutine stdlib${ii}$_${ci}$unml2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sorglq( m, n, k, a, lda, tau, work, lwork, info )
!! SORGLQ generates an M-by-N real matrix Q with orthonormal rows,
!! which is defined as the first M rows of a product of K elementary
!! reflectors of order N
!! Q = H(k) . . . H(2) H(1)
!! as returned by SGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGLQ', ' ', m, n, k, -1_${ik}$ )
lwkopt = max( 1_${ik}$, m )*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORGLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m<=0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'SORGLQ', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SORGLQ', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the last block.
! the first kk rows are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
! set a(kk+1:m,1:kk) to zero.
do j = 1, kk
do i = kk + 1, m
a( i, j ) = zero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the last or only block.
if( kk<m )call stdlib${ii}$_sorgl2( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,tau( kk+1 ), work,&
iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = ki + 1, 1, -nb
ib = min( nb, k-i+1 )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_slarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h**t to a(i+ib:m,i:n) from the right
call stdlib${ii}$_slarfb( 'RIGHT', 'TRANSPOSE', 'FORWARD', 'ROWWISE',m-i-ib+1, n-i+&
1_${ik}$, ib, a( i, i ), lda, work,ldwork, a( i+ib, i ), lda, work( ib+1 ),ldwork )
end if
! apply h**t to columns i:n of current block
call stdlib${ii}$_sorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo )
! set columns 1:i-1 of current block to zero
do j = 1, i - 1
do l = i, i + ib - 1
a( l, j ) = zero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_sorglq
pure module subroutine stdlib${ii}$_dorglq( m, n, k, a, lda, tau, work, lwork, info )
!! DORGLQ generates an M-by-N real matrix Q with orthonormal rows,
!! which is defined as the first M rows of a product of K elementary
!! reflectors of order N
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGLQ', ' ', m, n, k, -1_${ik}$ )
lwkopt = max( 1_${ik}$, m )*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m<=0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'DORGLQ', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DORGLQ', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the last block.
! the first kk rows are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
! set a(kk+1:m,1:kk) to zero.
do j = 1, kk
do i = kk + 1, m
a( i, j ) = zero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the last or only block.
if( kk<m )call stdlib${ii}$_dorgl2( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,tau( kk+1 ), work,&
iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = ki + 1, 1, -nb
ib = min( nb, k-i+1 )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_dlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h**t to a(i+ib:m,i:n) from the right
call stdlib${ii}$_dlarfb( 'RIGHT', 'TRANSPOSE', 'FORWARD', 'ROWWISE',m-i-ib+1, n-i+&
1_${ik}$, ib, a( i, i ), lda, work,ldwork, a( i+ib, i ), lda, work( ib+1 ),ldwork )
end if
! apply h**t to columns i:n of current block
call stdlib${ii}$_dorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo )
! set columns 1:i-1 of current block to zero
do j = 1, i - 1
do l = i, i + ib - 1
a( l, j ) = zero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_dorglq
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$orglq( m, n, k, a, lda, tau, work, lwork, info )
!! DORGLQ: generates an M-by-N real matrix Q with orthonormal rows,
!! which is defined as the first M rows of a product of K elementary
!! reflectors of order N
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGLQ', ' ', m, n, k, -1_${ik}$ )
lwkopt = max( 1_${ik}$, m )*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( lwork<max( 1_${ik}$, m ) .and. .not.lquery ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m<=0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = m
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'DORGLQ', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = m
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DORGLQ', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the last block.
! the first kk rows are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
! set a(kk+1:m,1:kk) to zero.
do j = 1, kk
do i = kk + 1, m
a( i, j ) = zero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the last or only block.
if( kk<m )call stdlib${ii}$_${ri}$orgl2( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,tau( kk+1 ), work,&
iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = ki + 1, 1, -nb
ib = min( nb, k-i+1 )
if( i+ib<=m ) then
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_${ri}$larft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), &
work, ldwork )
! apply h**t to a(i+ib:m,i:n) from the right
call stdlib${ii}$_${ri}$larfb( 'RIGHT', 'TRANSPOSE', 'FORWARD', 'ROWWISE',m-i-ib+1, n-i+&
1_${ik}$, ib, a( i, i ), lda, work,ldwork, a( i+ib, i ), lda, work( ib+1 ),ldwork )
end if
! apply h**t to columns i:n of current block
call stdlib${ii}$_${ri}$orgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo )
! set columns 1:i-1 of current block to zero
do j = 1, i - 1
do l = i, i + ib - 1
a( l, j ) = zero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ri}$orglq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sorgl2( m, n, k, a, lda, tau, work, info )
!! SORGL2 generates an m by n real matrix Q with orthonormal rows,
!! which is defined as the first m rows of a product of k elementary
!! reflectors of order n
!! Q = H(k) . . . H(2) H(1)
!! as returned by SGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(in) :: tau(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORGL2', -info )
return
end if
! quick return if possible
if( m<=0 )return
if( k<m ) then
! initialise rows k+1:m to rows of the unit matrix
do j = 1, n
do l = k + 1, m
a( l, j ) = zero
end do
if( j>k .and. j<=m )a( j, j ) = one
end do
end if
do i = k, 1, -1
! apply h(i) to a(i:m,i:n) from the right
if( i<n ) then
if( i<m ) then
a( i, i ) = one
call stdlib${ii}$_slarf( 'RIGHT', m-i, n-i+1, a( i, i ), lda,tau( i ), a( i+1, i ), &
lda, work )
end if
call stdlib${ii}$_sscal( n-i, -tau( i ), a( i, i+1 ), lda )
end if
a( i, i ) = one - tau( i )
! set a(i,1:i-1) to zero
do l = 1, i - 1
a( i, l ) = zero
end do
end do
return
end subroutine stdlib${ii}$_sorgl2
pure module subroutine stdlib${ii}$_dorgl2( m, n, k, a, lda, tau, work, info )
!! DORGL2 generates an m by n real matrix Q with orthonormal rows,
!! which is defined as the first m rows of a product of k elementary
!! reflectors of order n
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(in) :: tau(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGL2', -info )
return
end if
! quick return if possible
if( m<=0 )return
if( k<m ) then
! initialise rows k+1:m to rows of the unit matrix
do j = 1, n
do l = k + 1, m
a( l, j ) = zero
end do
if( j>k .and. j<=m )a( j, j ) = one
end do
end if
do i = k, 1, -1
! apply h(i) to a(i:m,i:n) from the right
if( i<n ) then
if( i<m ) then
a( i, i ) = one
call stdlib${ii}$_dlarf( 'RIGHT', m-i, n-i+1, a( i, i ), lda,tau( i ), a( i+1, i ), &
lda, work )
end if
call stdlib${ii}$_dscal( n-i, -tau( i ), a( i, i+1 ), lda )
end if
a( i, i ) = one - tau( i )
! set a(i,1:i-1) to zero
do l = 1, i - 1
a( i, l ) = zero
end do
end do
return
end subroutine stdlib${ii}$_dorgl2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$orgl2( m, n, k, a, lda, tau, work, info )
!! DORGL2: generates an m by n real matrix Q with orthonormal rows,
!! which is defined as the first m rows of a product of k elementary
!! reflectors of order n
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGELQF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(in) :: tau(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>m ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGL2', -info )
return
end if
! quick return if possible
if( m<=0 )return
if( k<m ) then
! initialise rows k+1:m to rows of the unit matrix
do j = 1, n
do l = k + 1, m
a( l, j ) = zero
end do
if( j>k .and. j<=m )a( j, j ) = one
end do
end if
do i = k, 1, -1
! apply h(i) to a(i:m,i:n) from the right
if( i<n ) then
if( i<m ) then
a( i, i ) = one
call stdlib${ii}$_${ri}$larf( 'RIGHT', m-i, n-i+1, a( i, i ), lda,tau( i ), a( i+1, i ), &
lda, work )
end if
call stdlib${ii}$_${ri}$scal( n-i, -tau( i ), a( i, i+1 ), lda )
end if
a( i, i ) = one - tau( i )
! set a(i,1:i-1) to zero
do l = 1, i - 1
a( i, l ) = zero
end do
end do
return
end subroutine stdlib${ii}$_${ri}$orgl2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sormlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! SORMLQ 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*), c(ldc,*)
real(sp), intent(in) :: tau(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
character :: transt
integer(${ik}$) :: i, i1, i2, i3, ib, ic, iinfo, iwt, jc, ldwork, lwkopt, mi, nb, nbmin, &
ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMLQ', side // trans, m, n, k,-1_${ik}$ ) )
lwkopt = nw*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SORMLQ', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_sorml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_slarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), &
work( iwt ), ldt )
if( left ) then
! h or h**t is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h or h**t is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h or h**t
call stdlib${ii}$_slarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), &
lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sormlq
pure module subroutine stdlib${ii}$_dormlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! DORMLQ 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*), c(ldc,*)
real(dp), intent(in) :: tau(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
character :: transt
integer(${ik}$) :: i, i1, i2, i3, ib, ic, iinfo, iwt, jc, ldwork, lwkopt, mi, nb, nbmin, &
ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMLQ', side // trans, m, n, k,-1_${ik}$ ) )
lwkopt = nw*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DORMLQ', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_dorml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_dlarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), &
work( iwt ), ldt )
if( left ) then
! h or h**t is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h or h**t is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h or h**t
call stdlib${ii}$_dlarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), &
lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dormlq
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ormlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! DORMLQ: 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*)
real(${rk}$), intent(in) :: tau(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
character :: transt
integer(${ik}$) :: i, i1, i2, i3, ib, ic, iinfo, iwt, jc, ldwork, lwkopt, mi, nb, nbmin, &
ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMLQ', side // trans, m, n, k,-1_${ik}$ ) )
lwkopt = nw*nb + tsize
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORMLQ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. k==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DORMLQ', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_${ri}$orml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i) h(i+1) . . . h(i+ib-1)
call stdlib${ii}$_${ri}$larft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), &
work( iwt ), ldt )
if( left ) then
! h or h**t is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h or h**t is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h or h**t
call stdlib${ii}$_${ri}$larfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), &
lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$ormlq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sorml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! SORML2 overwrites the general real m by n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**T* C if SIDE = 'L' and TRANS = 'T', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**T if SIDE = 'R' and TRANS = 'T',
!! where Q is a real orthogonal matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, ic, jc, mi, ni, nq
real(sp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORML2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran ) .or. ( .not.left .and. .not.notran ) )then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
do i = i1, i2, i3
if( left ) then
! h(i) is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h(i) is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h(i)
aii = a( i, i )
a( i, i ) = one
call stdlib${ii}$_slarf( side, mi, ni, a( i, i ), lda, tau( i ),c( ic, jc ), ldc, work )
a( i, i ) = aii
end do
return
end subroutine stdlib${ii}$_sorml2
pure module subroutine stdlib${ii}$_dorml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! DORML2 overwrites the general real m by n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**T* C if SIDE = 'L' and TRANS = 'T', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**T if SIDE = 'R' and TRANS = 'T',
!! where Q is a real orthogonal matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, ic, jc, mi, ni, nq
real(dp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORML2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran ) .or. ( .not.left .and. .not.notran ) )then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
do i = i1, i2, i3
if( left ) then
! h(i) is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h(i) is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h(i)
aii = a( i, i )
a( i, i ) = one
call stdlib${ii}$_dlarf( side, mi, ni, a( i, i ), lda, tau( i ),c( ic, jc ), ldc, work )
a( i, i ) = aii
end do
return
end subroutine stdlib${ii}$_dorml2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$orml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! DORML2: overwrites the general real m by n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**T* C if SIDE = 'L' and TRANS = 'T', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**T if SIDE = 'R' and TRANS = 'T',
!! where Q is a real orthogonal matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, ic, jc, mi, ni, nq
real(${rk}$) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORML2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran ) .or. ( .not.left .and. .not.notran ) )then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
jc = 1_${ik}$
else
mi = m
ic = 1_${ik}$
end if
do i = i1, i2, i3
if( left ) then
! h(i) is applied to c(i:m,1:n)
mi = m - i + 1_${ik}$
ic = i
else
! h(i) is applied to c(1:m,i:n)
ni = n - i + 1_${ik}$
jc = i
end if
! apply h(i)
aii = a( i, i )
a( i, i ) = one
call stdlib${ii}$_${ri}$larf( side, mi, ni, a( i, i ), lda, tau( i ),c( ic, jc ), ldc, work )
a( i, i ) = aii
end do
return
end subroutine stdlib${ii}$_${ri}$orml2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgelqt( m, n, mb, a, lda, t, ldt, work, info )
!! DGELQT computes a blocked LQ factorization of a real M-by-N matrix A
!! using the compact WY representation of Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldt, m, n, mb
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, iinfo, k
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>min(m,n) .and. min(m,n)>0_${ik}$ ) )then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldt<mb ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGELQT', -info )
return
end if
! quick return if possible
k = min( m, n )
if( k==0 ) return
! blocked loop of length k
do i = 1, k, mb
ib = min( k-i+1, mb )
! compute the lq factorization of the current block a(i:m,i:i+ib-1)
call stdlib${ii}$_sgelqt3( ib, n-i+1, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo )
if( i+ib<=m ) then
! update by applying h**t to a(i:m,i+ib:n) from the right
call stdlib${ii}$_slarfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,a( i, i ), lda, t( 1_${ik}$, i &
), ldt,a( i+ib, i ), lda, work , m-i-ib+1 )
end if
end do
return
end subroutine stdlib${ii}$_sgelqt
pure module subroutine stdlib${ii}$_dgelqt( m, n, mb, a, lda, t, ldt, work, info )
!! DGELQT computes a blocked LQ factorization of a real M-by-N matrix A
!! using the compact WY representation of Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldt, m, n, mb
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, iinfo, k
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>min(m,n) .and. min(m,n)>0_${ik}$ ) )then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldt<mb ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQT', -info )
return
end if
! quick return if possible
k = min( m, n )
if( k==0 ) return
! blocked loop of length k
do i = 1, k, mb
ib = min( k-i+1, mb )
! compute the lq factorization of the current block a(i:m,i:i+ib-1)
call stdlib${ii}$_dgelqt3( ib, n-i+1, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo )
if( i+ib<=m ) then
! update by applying h**t to a(i:m,i+ib:n) from the right
call stdlib${ii}$_dlarfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,a( i, i ), lda, t( 1_${ik}$, i &
), ldt,a( i+ib, i ), lda, work , m-i-ib+1 )
end if
end do
return
end subroutine stdlib${ii}$_dgelqt
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gelqt( m, n, mb, a, lda, t, ldt, work, info )
!! DGELQT: computes a blocked LQ factorization of a real M-by-N matrix A
!! using the compact WY representation of Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldt, m, n, mb
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, iinfo, k
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>min(m,n) .and. min(m,n)>0_${ik}$ ) )then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldt<mb ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQT', -info )
return
end if
! quick return if possible
k = min( m, n )
if( k==0 ) return
! blocked loop of length k
do i = 1, k, mb
ib = min( k-i+1, mb )
! compute the lq factorization of the current block a(i:m,i:i+ib-1)
call stdlib${ii}$_${ri}$gelqt3( ib, n-i+1, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo )
if( i+ib<=m ) then
! update by applying h**t to a(i:m,i+ib:n) from the right
call stdlib${ii}$_${ri}$larfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,a( i, i ), lda, t( 1_${ik}$, i &
), ldt,a( i+ib, i ), lda, work , m-i-ib+1 )
end if
end do
return
end subroutine stdlib${ii}$_${ri}$gelqt
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgelqt( m, n, mb, a, lda, t, ldt, work, info )
!! CGELQT computes a blocked LQ factorization of a complex M-by-N matrix A
!! using the compact WY representation of Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldt, m, n, mb
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, iinfo, k
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. (mb>min(m,n) .and. min(m,n)>0_${ik}$ ))then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldt<mb ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGELQT', -info )
return
end if
! quick return if possible
k = min( m, n )
if( k==0 ) return
! blocked loop of length k
do i = 1, k, mb
ib = min( k-i+1, mb )
! compute the lq factorization of the current block a(i:m,i:i+ib-1)
call stdlib${ii}$_cgelqt3( ib, n-i+1, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo )
if( i+ib<=m ) then
! update by applying h**t to a(i:m,i+ib:n) from the right
call stdlib${ii}$_clarfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,a( i, i ), lda, t( 1_${ik}$, i &
), ldt,a( i+ib, i ), lda, work , m-i-ib+1 )
end if
end do
return
end subroutine stdlib${ii}$_cgelqt
pure module subroutine stdlib${ii}$_zgelqt( m, n, mb, a, lda, t, ldt, work, info )
!! ZGELQT computes a blocked LQ factorization of a complex M-by-N matrix A
!! using the compact WY representation of Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldt, m, n, mb
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, iinfo, k
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. (mb>min(m,n) .and. min(m,n)>0_${ik}$ ))then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldt<mb ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQT', -info )
return
end if
! quick return if possible
k = min( m, n )
if( k==0 ) return
! blocked loop of length k
do i = 1, k, mb
ib = min( k-i+1, mb )
! compute the lq factorization of the current block a(i:m,i:i+ib-1)
call stdlib${ii}$_zgelqt3( ib, n-i+1, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo )
if( i+ib<=m ) then
! update by applying h**t to a(i:m,i+ib:n) from the right
call stdlib${ii}$_zlarfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,a( i, i ), lda, t( 1_${ik}$, i &
), ldt,a( i+ib, i ), lda, work , m-i-ib+1 )
end if
end do
return
end subroutine stdlib${ii}$_zgelqt
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gelqt( m, n, mb, a, lda, t, ldt, work, info )
!! ZGELQT: computes a blocked LQ factorization of a complex M-by-N matrix A
!! using the compact WY representation of Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldt, m, n, mb
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, iinfo, k
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. (mb>min(m,n) .and. min(m,n)>0_${ik}$ ))then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldt<mb ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQT', -info )
return
end if
! quick return if possible
k = min( m, n )
if( k==0 ) return
! blocked loop of length k
do i = 1, k, mb
ib = min( k-i+1, mb )
! compute the lq factorization of the current block a(i:m,i:i+ib-1)
call stdlib${ii}$_${ci}$gelqt3( ib, n-i+1, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo )
if( i+ib<=m ) then
! update by applying h**t to a(i:m,i+ib:n) from the right
call stdlib${ii}$_${ci}$larfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,a( i, i ), lda, t( 1_${ik}$, i &
), ldt,a( i+ib, i ), lda, work , m-i-ib+1 )
end if
end do
return
end subroutine stdlib${ii}$_${ci}$gelqt
#:endif
#:endfor
pure recursive module subroutine stdlib${ii}$_sgelqt3( m, n, a, lda, t, ldt, info )
!! SGELQT3 recursively computes a LQ factorization of a real M-by-N
!! matrix A, using the compact WY representation of Q.
!! Based on the algorithm of Elmroth and Gustavson,
!! IBM J. Res. Develop. Vol 44 No. 4 July 2000.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, ldt
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, j, j1, m1, m2, iinfo
! Executable Statements
info = 0_${ik}$
if( m < 0_${ik}$ ) then
info = -1_${ik}$
else if( n < m ) then
info = -2_${ik}$
else if( lda < max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( ldt < max( 1_${ik}$, m ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGELQT3', -info )
return
end if
if( m==1_${ik}$ ) then
! compute householder transform when m=1
call stdlib${ii}$_slarfg( n, a(1_${ik}$,1_${ik}$), a( 1_${ik}$, min( 2_${ik}$, n ) ), lda, t(1_${ik}$,1_${ik}$) )
else
! otherwise, split a into blocks...
m1 = m/2_${ik}$
m2 = m-m1
i1 = min( m1+1, m )
j1 = min( m+1, n )
! compute a(1:m1,1:n) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h
call stdlib${ii}$_sgelqt3( m1, n, a, lda, t, ldt, iinfo )
! compute a(j1:m,1:n) = q1^h a(j1:m,1:n) [workspace: t(1:n1,j1:n)]
do i=1,m2
do j=1,m1
t( i+m1, j ) = a( i+m1, j )
end do
end do
call stdlib${ii}$_strmm( 'R', 'U', 'T', 'U', m2, m1, one,a, lda, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_sgemm( 'N', 'T', m2, m1, n-m1, one, a( i1, i1 ), lda,a( 1_${ik}$, i1 ), lda, &
one, t( i1, 1_${ik}$ ), ldt)
call stdlib${ii}$_strmm( 'R', 'U', 'N', 'N', m2, m1, one,t, ldt, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_sgemm( 'N', 'N', m2, n-m1, m1, -one, t( i1, 1_${ik}$ ), ldt,a( 1_${ik}$, i1 ), lda, &
one, a( i1, i1 ), lda )
call stdlib${ii}$_strmm( 'R', 'U', 'N', 'U', m2, m1 , one,a, lda, t( i1, 1_${ik}$ ), ldt )
do i=1,m2
do j=1,m1
a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
t( i+m1, j )=0_${ik}$
end do
end do
! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h
call stdlib${ii}$_sgelqt3( m2, n-m1, a( i1, i1 ), lda,t( i1, i1 ), ldt, iinfo )
! compute t3 = t(j1:n1,1:n) = -t1 y1^h y2 t2
do i=1,m2
do j=1,m1
t( j, i+m1 ) = (a( j, i+m1 ))
end do
end do
call stdlib${ii}$_strmm( 'R', 'U', 'T', 'U', m1, m2, one,a( i1, i1 ), lda, t( 1_${ik}$, i1 ), &
ldt )
call stdlib${ii}$_sgemm( 'N', 'T', m1, m2, n-m, one, a( 1_${ik}$, j1 ), lda,a( i1, j1 ), lda, &
one, t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', m1, m2, -one, t, ldt,t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_strmm( 'R', 'U', 'N', 'N', m1, m2, one,t( i1, i1 ), ldt, t( 1_${ik}$, i1 ), &
ldt )
! y = (y1,y2); l = [ l1 0 ]; t = [t1 t3]
! [ a(1:n1,j1:n) l2 ] [ 0 t2]
end if
return
end subroutine stdlib${ii}$_sgelqt3
pure recursive module subroutine stdlib${ii}$_dgelqt3( m, n, a, lda, t, ldt, info )
!! DGELQT3 recursively computes a LQ factorization of a real M-by-N
!! matrix A, using the compact WY representation of Q.
!! Based on the algorithm of Elmroth and Gustavson,
!! IBM J. Res. Develop. Vol 44 No. 4 July 2000.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, ldt
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, j, j1, m1, m2, iinfo
! Executable Statements
info = 0_${ik}$
if( m < 0_${ik}$ ) then
info = -1_${ik}$
else if( n < m ) then
info = -2_${ik}$
else if( lda < max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( ldt < max( 1_${ik}$, m ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQT3', -info )
return
end if
if( m==1_${ik}$ ) then
! compute householder transform when m=1
call stdlib${ii}$_dlarfg( n, a(1_${ik}$,1_${ik}$), a( 1_${ik}$, min( 2_${ik}$, n ) ), lda, t(1_${ik}$,1_${ik}$) )
else
! otherwise, split a into blocks...
m1 = m/2_${ik}$
m2 = m-m1
i1 = min( m1+1, m )
j1 = min( m+1, n )
! compute a(1:m1,1:n) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h
call stdlib${ii}$_dgelqt3( m1, n, a, lda, t, ldt, iinfo )
! compute a(j1:m,1:n) = q1^h a(j1:m,1:n) [workspace: t(1:n1,j1:n)]
do i=1,m2
do j=1,m1
t( i+m1, j ) = a( i+m1, j )
end do
end do
call stdlib${ii}$_dtrmm( 'R', 'U', 'T', 'U', m2, m1, one,a, lda, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_dgemm( 'N', 'T', m2, m1, n-m1, one, a( i1, i1 ), lda,a( 1_${ik}$, i1 ), lda, &
one, t( i1, 1_${ik}$ ), ldt)
call stdlib${ii}$_dtrmm( 'R', 'U', 'N', 'N', m2, m1, one,t, ldt, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_dgemm( 'N', 'N', m2, n-m1, m1, -one, t( i1, 1_${ik}$ ), ldt,a( 1_${ik}$, i1 ), lda, &
one, a( i1, i1 ), lda )
call stdlib${ii}$_dtrmm( 'R', 'U', 'N', 'U', m2, m1 , one,a, lda, t( i1, 1_${ik}$ ), ldt )
do i=1,m2
do j=1,m1
a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
t( i+m1, j )=0_${ik}$
end do
end do
! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h
call stdlib${ii}$_dgelqt3( m2, n-m1, a( i1, i1 ), lda,t( i1, i1 ), ldt, iinfo )
! compute t3 = t(j1:n1,1:n) = -t1 y1^h y2 t2
do i=1,m2
do j=1,m1
t( j, i+m1 ) = (a( j, i+m1 ))
end do
end do
call stdlib${ii}$_dtrmm( 'R', 'U', 'T', 'U', m1, m2, one,a( i1, i1 ), lda, t( 1_${ik}$, i1 ), &
ldt )
call stdlib${ii}$_dgemm( 'N', 'T', m1, m2, n-m, one, a( 1_${ik}$, j1 ), lda,a( i1, j1 ), lda, &
one, t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', m1, m2, -one, t, ldt,t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_dtrmm( 'R', 'U', 'N', 'N', m1, m2, one,t( i1, i1 ), ldt, t( 1_${ik}$, i1 ), &
ldt )
! y = (y1,y2); l = [ l1 0 ]; t = [t1 t3]
! [ a(1:n1,j1:n) l2 ] [ 0 t2]
end if
return
end subroutine stdlib${ii}$_dgelqt3
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure recursive module subroutine stdlib${ii}$_${ri}$gelqt3( m, n, a, lda, t, ldt, info )
!! DGELQT3: recursively computes a LQ factorization of a real M-by-N
!! matrix A, using the compact WY representation of Q.
!! Based on the algorithm of Elmroth and Gustavson,
!! IBM J. Res. Develop. Vol 44 No. 4 July 2000.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, ldt
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, j, j1, m1, m2, iinfo
! Executable Statements
info = 0_${ik}$
if( m < 0_${ik}$ ) then
info = -1_${ik}$
else if( n < m ) then
info = -2_${ik}$
else if( lda < max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( ldt < max( 1_${ik}$, m ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGELQT3', -info )
return
end if
if( m==1_${ik}$ ) then
! compute householder transform when m=1
call stdlib${ii}$_${ri}$larfg( n, a(1_${ik}$,1_${ik}$), a( 1_${ik}$, min( 2_${ik}$, n ) ), lda, t(1_${ik}$,1_${ik}$) )
else
! otherwise, split a into blocks...
m1 = m/2_${ik}$
m2 = m-m1
i1 = min( m1+1, m )
j1 = min( m+1, n )
! compute a(1:m1,1:n) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h
call stdlib${ii}$_${ri}$gelqt3( m1, n, a, lda, t, ldt, iinfo )
! compute a(j1:m,1:n) = q1^h a(j1:m,1:n) [workspace: t(1:n1,j1:n)]
do i=1,m2
do j=1,m1
t( i+m1, j ) = a( i+m1, j )
end do
end do
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'T', 'U', m2, m1, one,a, lda, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_${ri}$gemm( 'N', 'T', m2, m1, n-m1, one, a( i1, i1 ), lda,a( 1_${ik}$, i1 ), lda, &
one, t( i1, 1_${ik}$ ), ldt)
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'N', 'N', m2, m1, one,t, ldt, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_${ri}$gemm( 'N', 'N', m2, n-m1, m1, -one, t( i1, 1_${ik}$ ), ldt,a( 1_${ik}$, i1 ), lda, &
one, a( i1, i1 ), lda )
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'N', 'U', m2, m1 , one,a, lda, t( i1, 1_${ik}$ ), ldt )
do i=1,m2
do j=1,m1
a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
t( i+m1, j )=0_${ik}$
end do
end do
! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h
call stdlib${ii}$_${ri}$gelqt3( m2, n-m1, a( i1, i1 ), lda,t( i1, i1 ), ldt, iinfo )
! compute t3 = t(j1:n1,1:n) = -t1 y1^h y2 t2
do i=1,m2
do j=1,m1
t( j, i+m1 ) = (a( j, i+m1 ))
end do
end do
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'T', 'U', m1, m2, one,a( i1, i1 ), lda, t( 1_${ik}$, i1 ), &
ldt )
call stdlib${ii}$_${ri}$gemm( 'N', 'T', m1, m2, n-m, one, a( 1_${ik}$, j1 ), lda,a( i1, j1 ), lda, &
one, t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', m1, m2, -one, t, ldt,t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'N', 'N', m1, m2, one,t( i1, i1 ), ldt, t( 1_${ik}$, i1 ), &
ldt )
! y = (y1,y2); l = [ l1 0 ]; t = [t1 t3]
! [ a(1:n1,j1:n) l2 ] [ 0 t2]
end if
return
end subroutine stdlib${ii}$_${ri}$gelqt3
#:endif
#:endfor
pure recursive module subroutine stdlib${ii}$_cgelqt3( m, n, a, lda, t, ldt, info )
!! CGELQT3 recursively computes a LQ factorization of a complex M-by-N
!! matrix A, using the compact WY representation of Q.
!! Based on the algorithm of Elmroth and Gustavson,
!! IBM J. Res. Develop. Vol 44 No. 4 July 2000.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, ldt
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, j, j1, m1, m2, iinfo
! Executable Statements
info = 0_${ik}$
if( m < 0_${ik}$ ) then
info = -1_${ik}$
else if( n < m ) then
info = -2_${ik}$
else if( lda < max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( ldt < max( 1_${ik}$, m ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGELQT3', -info )
return
end if
if( m==1_${ik}$ ) then
! compute householder transform when m=1
call stdlib${ii}$_clarfg( n, a(1_${ik}$,1_${ik}$), a( 1_${ik}$, min( 2_${ik}$, n ) ), lda, t(1_${ik}$,1_${ik}$) )
t(1_${ik}$,1_${ik}$)=conjg(t(1_${ik}$,1_${ik}$))
else
! otherwise, split a into blocks...
m1 = m/2_${ik}$
m2 = m-m1
i1 = min( m1+1, m )
j1 = min( m+1, n )
! compute a(1:m1,1:n) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h
call stdlib${ii}$_cgelqt3( m1, n, a, lda, t, ldt, iinfo )
! compute a(j1:m,1:n) = a(j1:m,1:n) q1^h [workspace: t(1:n1,j1:n)]
do i=1,m2
do j=1,m1
t( i+m1, j ) = a( i+m1, j )
end do
end do
call stdlib${ii}$_ctrmm( 'R', 'U', 'C', 'U', m2, m1, cone,a, lda, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_cgemm( 'N', 'C', m2, m1, n-m1, cone, a( i1, i1 ), lda,a( 1_${ik}$, i1 ), lda, &
cone, t( i1, 1_${ik}$ ), ldt)
call stdlib${ii}$_ctrmm( 'R', 'U', 'N', 'N', m2, m1, cone,t, ldt, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_cgemm( 'N', 'N', m2, n-m1, m1, -cone, t( i1, 1_${ik}$ ), ldt,a( 1_${ik}$, i1 ), lda, &
cone, a( i1, i1 ), lda )
call stdlib${ii}$_ctrmm( 'R', 'U', 'N', 'U', m2, m1 , cone,a, lda, t( i1, 1_${ik}$ ), ldt )
do i=1,m2
do j=1,m1
a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
t( i+m1, j )= czero
end do
end do
! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h
call stdlib${ii}$_cgelqt3( m2, n-m1, a( i1, i1 ), lda,t( i1, i1 ), ldt, iinfo )
! compute t3 = t(j1:n1,1:n) = -t1 y1^h y2 t2
do i=1,m2
do j=1,m1
t( j, i+m1 ) = (a( j, i+m1 ))
end do
end do
call stdlib${ii}$_ctrmm( 'R', 'U', 'C', 'U', m1, m2, cone,a( i1, i1 ), lda, t( 1_${ik}$, i1 ), &
ldt )
call stdlib${ii}$_cgemm( 'N', 'C', m1, m2, n-m, cone, a( 1_${ik}$, j1 ), lda,a( i1, j1 ), lda, &
cone, t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', m1, m2, -cone, t, ldt,t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_ctrmm( 'R', 'U', 'N', 'N', m1, m2, cone,t( i1, i1 ), ldt, t( 1_${ik}$, i1 ), &
ldt )
! y = (y1,y2); l = [ l1 0 ]; t = [t1 t3]
! [ a(1:n1,j1:n) l2 ] [ 0 t2]
end if
return
end subroutine stdlib${ii}$_cgelqt3
pure recursive module subroutine stdlib${ii}$_zgelqt3( m, n, a, lda, t, ldt, info )
!! ZGELQT3 recursively computes a LQ factorization of a complex M-by-N
!! matrix A, using the compact WY representation of Q.
!! Based on the algorithm of Elmroth and Gustavson,
!! IBM J. Res. Develop. Vol 44 No. 4 July 2000.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, ldt
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, j, j1, m1, m2, iinfo
! Executable Statements
info = 0_${ik}$
if( m < 0_${ik}$ ) then
info = -1_${ik}$
else if( n < m ) then
info = -2_${ik}$
else if( lda < max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( ldt < max( 1_${ik}$, m ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQT3', -info )
return
end if
if( m==1_${ik}$ ) then
! compute householder transform when m=1
call stdlib${ii}$_zlarfg( n, a(1_${ik}$,1_${ik}$), a( 1_${ik}$, min( 2_${ik}$, n ) ), lda, t(1_${ik}$,1_${ik}$) )
t(1_${ik}$,1_${ik}$)=conjg(t(1_${ik}$,1_${ik}$))
else
! otherwise, split a into blocks...
m1 = m/2_${ik}$
m2 = m-m1
i1 = min( m1+1, m )
j1 = min( m+1, n )
! compute a(1:m1,1:n) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h
call stdlib${ii}$_zgelqt3( m1, n, a, lda, t, ldt, iinfo )
! compute a(j1:m,1:n) = a(j1:m,1:n) q1^h [workspace: t(1:n1,j1:n)]
do i=1,m2
do j=1,m1
t( i+m1, j ) = a( i+m1, j )
end do
end do
call stdlib${ii}$_ztrmm( 'R', 'U', 'C', 'U', m2, m1, cone,a, lda, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_zgemm( 'N', 'C', m2, m1, n-m1, cone, a( i1, i1 ), lda,a( 1_${ik}$, i1 ), lda, &
cone, t( i1, 1_${ik}$ ), ldt)
call stdlib${ii}$_ztrmm( 'R', 'U', 'N', 'N', m2, m1, cone,t, ldt, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_zgemm( 'N', 'N', m2, n-m1, m1, -cone, t( i1, 1_${ik}$ ), ldt,a( 1_${ik}$, i1 ), lda, &
cone, a( i1, i1 ), lda )
call stdlib${ii}$_ztrmm( 'R', 'U', 'N', 'U', m2, m1 , cone,a, lda, t( i1, 1_${ik}$ ), ldt )
do i=1,m2
do j=1,m1
a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
t( i+m1, j )= czero
end do
end do
! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h
call stdlib${ii}$_zgelqt3( m2, n-m1, a( i1, i1 ), lda,t( i1, i1 ), ldt, iinfo )
! compute t3 = t(j1:n1,1:n) = -t1 y1^h y2 t2
do i=1,m2
do j=1,m1
t( j, i+m1 ) = (a( j, i+m1 ))
end do
end do
call stdlib${ii}$_ztrmm( 'R', 'U', 'C', 'U', m1, m2, cone,a( i1, i1 ), lda, t( 1_${ik}$, i1 ), &
ldt )
call stdlib${ii}$_zgemm( 'N', 'C', m1, m2, n-m, cone, a( 1_${ik}$, j1 ), lda,a( i1, j1 ), lda, &
cone, t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', m1, m2, -cone, t, ldt,t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_ztrmm( 'R', 'U', 'N', 'N', m1, m2, cone,t( i1, i1 ), ldt, t( 1_${ik}$, i1 ), &
ldt )
! y = (y1,y2); l = [ l1 0 ]; t = [t1 t3]
! [ a(1:n1,j1:n) l2 ] [ 0 t2]
end if
return
end subroutine stdlib${ii}$_zgelqt3
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure recursive module subroutine stdlib${ii}$_${ci}$gelqt3( m, n, a, lda, t, ldt, info )
!! ZGELQT3: recursively computes a LQ factorization of a complex M-by-N
!! matrix A, using the compact WY representation of Q.
!! Based on the algorithm of Elmroth and Gustavson,
!! IBM J. Res. Develop. Vol 44 No. 4 July 2000.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, ldt
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, j, j1, m1, m2, iinfo
! Executable Statements
info = 0_${ik}$
if( m < 0_${ik}$ ) then
info = -1_${ik}$
else if( n < m ) then
info = -2_${ik}$
else if( lda < max( 1_${ik}$, m ) ) then
info = -4_${ik}$
else if( ldt < max( 1_${ik}$, m ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGELQT3', -info )
return
end if
if( m==1_${ik}$ ) then
! compute householder transform when m=1
call stdlib${ii}$_${ci}$larfg( n, a(1_${ik}$,1_${ik}$), a( 1_${ik}$, min( 2_${ik}$, n ) ), lda, t(1_${ik}$,1_${ik}$) )
t(1_${ik}$,1_${ik}$)=conjg(t(1_${ik}$,1_${ik}$))
else
! otherwise, split a into blocks...
m1 = m/2_${ik}$
m2 = m-m1
i1 = min( m1+1, m )
j1 = min( m+1, n )
! compute a(1:m1,1:n) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h
call stdlib${ii}$_${ci}$gelqt3( m1, n, a, lda, t, ldt, iinfo )
! compute a(j1:m,1:n) = a(j1:m,1:n) q1^h [workspace: t(1:n1,j1:n)]
do i=1,m2
do j=1,m1
t( i+m1, j ) = a( i+m1, j )
end do
end do
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', 'U', m2, m1, cone,a, lda, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_${ci}$gemm( 'N', 'C', m2, m1, n-m1, cone, a( i1, i1 ), lda,a( 1_${ik}$, i1 ), lda, &
cone, t( i1, 1_${ik}$ ), ldt)
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', 'N', m2, m1, cone,t, ldt, t( i1, 1_${ik}$ ), ldt )
call stdlib${ii}$_${ci}$gemm( 'N', 'N', m2, n-m1, m1, -cone, t( i1, 1_${ik}$ ), ldt,a( 1_${ik}$, i1 ), lda, &
cone, a( i1, i1 ), lda )
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', 'U', m2, m1 , cone,a, lda, t( i1, 1_${ik}$ ), ldt )
do i=1,m2
do j=1,m1
a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
t( i+m1, j )= czero
end do
end do
! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h
call stdlib${ii}$_${ci}$gelqt3( m2, n-m1, a( i1, i1 ), lda,t( i1, i1 ), ldt, iinfo )
! compute t3 = t(j1:n1,1:n) = -t1 y1^h y2 t2
do i=1,m2
do j=1,m1
t( j, i+m1 ) = (a( j, i+m1 ))
end do
end do
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', 'U', m1, m2, cone,a( i1, i1 ), lda, t( 1_${ik}$, i1 ), &
ldt )
call stdlib${ii}$_${ci}$gemm( 'N', 'C', m1, m2, n-m, cone, a( 1_${ik}$, j1 ), lda,a( i1, j1 ), lda, &
cone, t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', m1, m2, -cone, t, ldt,t( 1_${ik}$, i1 ), ldt )
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', 'N', m1, m2, cone,t( i1, i1 ), ldt, t( 1_${ik}$, i1 ), &
ldt )
! y = (y1,y2); l = [ l1 0 ]; t = [t1 t3]
! [ a(1:n1,j1:n) l2 ] [ 0 t2]
end if
return
end subroutine stdlib${ii}$_${ci}$gelqt3
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info )
!! DGEMLQT 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 defined as the product of K
!! elementary reflectors:
!! Q = H(1) H(2) . . . H(K) = I - V T V**T
!! generated using the compact WY representation as returned by SGELQT.
!! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, mb, ldt
! Array Arguments
real(sp), intent(in) :: v(ldv,*), t(ldt,*)
real(sp), intent(inout) :: c(ldc,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, ldwork, kf, q
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'T' )
notran = stdlib_lsame( trans, 'N' )
if( left ) then
ldwork = max( 1_${ik}$, n )
q = m
else if ( right ) then
ldwork = max( 1_${ik}$, m )
q = n
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>q ) then
info = -5_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$)) then
info = -6_${ik}$
else if( ldv<max( 1_${ik}$, k ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_slarfb( 'L', 'T', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_slarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_slarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_slarfb( 'R', 'T', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
end if
return
end subroutine stdlib${ii}$_sgemlqt
pure module subroutine stdlib${ii}$_dgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info )
!! DGEMLQT 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 defined as the product of K
!! elementary reflectors:
!! Q = H(1) H(2) . . . H(K) = I - V T V**T
!! generated using the compact WY representation as returned by DGELQT.
!! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, mb, ldt
! Array Arguments
real(dp), intent(in) :: v(ldv,*), t(ldt,*)
real(dp), intent(inout) :: c(ldc,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, ldwork, kf, q
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'T' )
notran = stdlib_lsame( trans, 'N' )
if( left ) then
ldwork = max( 1_${ik}$, n )
q = m
else if ( right ) then
ldwork = max( 1_${ik}$, m )
q = n
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>q ) then
info = -5_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$)) then
info = -6_${ik}$
else if( ldv<max( 1_${ik}$, k ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_dlarfb( 'L', 'T', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_dlarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_dlarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_dlarfb( 'R', 'T', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
end if
return
end subroutine stdlib${ii}$_dgemlqt
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info )
!! DGEMLQT: 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 defined as the product of K
!! elementary reflectors:
!! Q = H(1) H(2) . . . H(K) = I - V T V**T
!! generated using the compact WY representation as returned by DGELQT.
!! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, mb, ldt
! Array Arguments
real(${rk}$), intent(in) :: v(ldv,*), t(ldt,*)
real(${rk}$), intent(inout) :: c(ldc,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, ldwork, kf, q
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'T' )
notran = stdlib_lsame( trans, 'N' )
if( left ) then
ldwork = max( 1_${ik}$, n )
q = m
else if ( right ) then
ldwork = max( 1_${ik}$, m )
q = n
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>q ) then
info = -5_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$)) then
info = -6_${ik}$
else if( ldv<max( 1_${ik}$, k ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_${ri}$larfb( 'L', 'T', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_${ri}$larfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_${ri}$larfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_${ri}$larfb( 'R', 'T', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
end if
return
end subroutine stdlib${ii}$_${ri}$gemlqt
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info )
!! CGEMLQT 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 defined as the product of K
!! elementary reflectors:
!! Q = H(1) H(2) . . . H(K) = I - V T V**H
!! generated using the compact WY representation as returned by CGELQT.
!! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, mb, ldt
! Array Arguments
complex(sp), intent(in) :: v(ldv,*), t(ldt,*)
complex(sp), intent(inout) :: c(ldc,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, ldwork, kf, q
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'C' )
notran = stdlib_lsame( trans, 'N' )
if( left ) then
ldwork = max( 1_${ik}$, n )
q = m
else if ( right ) then
ldwork = max( 1_${ik}$, m )
q = n
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>q ) then
info = -5_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$)) then
info = -6_${ik}$
else if( ldv<max( 1_${ik}$, k ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_clarfb( 'L', 'C', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_clarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_clarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_clarfb( 'R', 'C', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
end if
return
end subroutine stdlib${ii}$_cgemlqt
pure module subroutine stdlib${ii}$_zgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info )
!! ZGEMLQT 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 defined as the product of K
!! elementary reflectors:
!! Q = H(1) H(2) . . . H(K) = I - V T V**H
!! generated using the compact WY representation as returned by ZGELQT.
!! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, mb, ldt
! Array Arguments
complex(dp), intent(in) :: v(ldv,*), t(ldt,*)
complex(dp), intent(inout) :: c(ldc,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, ldwork, kf, q
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'C' )
notran = stdlib_lsame( trans, 'N' )
if( left ) then
ldwork = max( 1_${ik}$, n )
q = m
else if ( right ) then
ldwork = max( 1_${ik}$, m )
q = n
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>q ) then
info = -5_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$)) then
info = -6_${ik}$
else if( ldv<max( 1_${ik}$, k ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_zlarfb( 'L', 'C', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_zlarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_zlarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_zlarfb( 'R', 'C', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
end if
return
end subroutine stdlib${ii}$_zgemlqt
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info )
!! ZGEMLQT: 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 defined as the product of K
!! elementary reflectors:
!! Q = H(1) H(2) . . . H(K) = I - V T V**H
!! generated using the compact WY representation as returned by ZGELQT.
!! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, mb, ldt
! Array Arguments
complex(${ck}$), intent(in) :: v(ldv,*), t(ldt,*)
complex(${ck}$), intent(inout) :: c(ldc,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, ldwork, kf, q
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'C' )
notran = stdlib_lsame( trans, 'N' )
if( left ) then
ldwork = max( 1_${ik}$, n )
q = m
else if ( right ) then
ldwork = max( 1_${ik}$, m )
q = n
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ .or. k>q ) then
info = -5_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$)) then
info = -6_${ik}$
else if( ldv<max( 1_${ik}$, k ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_${ci}$larfb( 'L', 'C', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_${ci}$larfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_${ci}$larfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( i, 1_${ik}$ ), ldc, work, ldwork )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
call stdlib${ii}$_${ci}$larfb( 'R', 'C', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1_${ik}$, i ), &
ldt,c( 1_${ik}$, i ), ldc, work, ldwork )
end do
end if
return
end subroutine stdlib${ii}$_${ci}$gemlqt
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info)
!! SLASWLQ computes a blocked Tall-Skinny LQ factorization of
!! a real M-by-N matrix A for M <= N:
!! A = ( L 0 ) * Q,
!! where:
!! Q is a n-by-N orthogonal matrix, stored on exit in an implicit
!! form in the elements above the diagonal of the array A and in
!! the elements of the array T;
!! L is a lower-triangular M-by-M matrix stored on exit in
!! the elements on and below the diagonal of the array A.
!! 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ii, kk, ctr
! External Subroutines
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n<m ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>m .and. m>0_${ik}$ )) then
info = -3_${ik}$
else if( nb<=0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldt<mb ) then
info = -8_${ik}$
else if( ( lwork<m*mb) .and. (.not.lquery) ) then
info = -10_${ik}$
end if
if( info==0_${ik}$) then
work(1_${ik}$) = mb*m
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLASWLQ', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( min(m,n)==0_${ik}$ ) then
return
end if
! the lq decomposition
if((m>=n).or.(nb<=m).or.(nb>=n)) then
call stdlib${ii}$_sgelqt( m, n, mb, a, lda, t, ldt, work, info)
return
end if
kk = mod((n-m),(nb-m))
ii=n-kk+1
! compute the lq factorization of the first block a(1:m,1:nb)
call stdlib${ii}$_sgelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info)
ctr = 1_${ik}$
do i = nb+1, ii-nb+m , (nb-m)
! compute the qr factorization of the current block a(1:m,i:i+nb-m)
call stdlib${ii}$_stplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),&
ldt, work, info )
ctr = ctr + 1_${ik}$
end do
! compute the qr factorization of the last block a(1:m,ii:n)
if (ii<=n) then
call stdlib${ii}$_stplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), &
ldt,work, info )
end if
work( 1_${ik}$ ) = m * mb
return
end subroutine stdlib${ii}$_slaswlq
pure module subroutine stdlib${ii}$_dlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info)
!! DLASWLQ computes a blocked Tall-Skinny LQ factorization of
!! a real M-by-N matrix A for M <= N:
!! A = ( L 0 ) * Q,
!! where:
!! Q is a n-by-N orthogonal matrix, stored on exit in an implicit
!! form in the elements above the diagonal of the array A and in
!! the elements of the array T;
!! L is a lower-triangular M-by-M matrix stored on exit in
!! the elements on and below the diagonal of the array A.
!! 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ii, kk, ctr
! External Subroutines
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n<m ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>m .and. m>0_${ik}$ )) then
info = -3_${ik}$
else if( nb<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldt<mb ) then
info = -8_${ik}$
else if( ( lwork<m*mb) .and. (.not.lquery) ) then
info = -10_${ik}$
end if
if( info==0_${ik}$) then
work(1_${ik}$) = mb*m
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLASWLQ', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( min(m,n)==0_${ik}$ ) then
return
end if
! the lq decomposition
if((m>=n).or.(nb<=m).or.(nb>=n)) then
call stdlib${ii}$_dgelqt( m, n, mb, a, lda, t, ldt, work, info)
return
end if
kk = mod((n-m),(nb-m))
ii=n-kk+1
! compute the lq factorization of the first block a(1:m,1:nb)
call stdlib${ii}$_dgelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info)
ctr = 1_${ik}$
do i = nb+1, ii-nb+m , (nb-m)
! compute the qr factorization of the current block a(1:m,i:i+nb-m)
call stdlib${ii}$_dtplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),&
ldt, work, info )
ctr = ctr + 1_${ik}$
end do
! compute the qr factorization of the last block a(1:m,ii:n)
if (ii<=n) then
call stdlib${ii}$_dtplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), &
ldt,work, info )
end if
work( 1_${ik}$ ) = m * mb
return
end subroutine stdlib${ii}$_dlaswlq
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info)
!! DLASWLQ: computes a blocked Tall-Skinny LQ factorization of
!! a real M-by-N matrix A for M <= N:
!! A = ( L 0 ) * Q,
!! where:
!! Q is a n-by-N orthogonal matrix, stored on exit in an implicit
!! form in the elements above the diagonal of the array A and in
!! the elements of the array T;
!! L is a lower-triangular M-by-M matrix stored on exit in
!! the elements on and below the diagonal of the array A.
!! 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ii, kk, ctr
! External Subroutines
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n<m ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>m .and. m>0_${ik}$ )) then
info = -3_${ik}$
else if( nb<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldt<mb ) then
info = -8_${ik}$
else if( ( lwork<m*mb) .and. (.not.lquery) ) then
info = -10_${ik}$
end if
if( info==0_${ik}$) then
work(1_${ik}$) = mb*m
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLASWLQ', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( min(m,n)==0_${ik}$ ) then
return
end if
! the lq decomposition
if((m>=n).or.(nb<=m).or.(nb>=n)) then
call stdlib${ii}$_${ri}$gelqt( m, n, mb, a, lda, t, ldt, work, info)
return
end if
kk = mod((n-m),(nb-m))
ii=n-kk+1
! compute the lq factorization of the first block a(1:m,1:nb)
call stdlib${ii}$_${ri}$gelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info)
ctr = 1_${ik}$
do i = nb+1, ii-nb+m , (nb-m)
! compute the qr factorization of the current block a(1:m,i:i+nb-m)
call stdlib${ii}$_${ri}$tplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),&
ldt, work, info )
ctr = ctr + 1_${ik}$
end do
! compute the qr factorization of the last block a(1:m,ii:n)
if (ii<=n) then
call stdlib${ii}$_${ri}$tplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), &
ldt,work, info )
end if
work( 1_${ik}$ ) = m * mb
return
end subroutine stdlib${ii}$_${ri}$laswlq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info)
!! CLASWLQ computes a blocked Tall-Skinny LQ factorization of
!! a complex M-by-N matrix A for M <= N:
!! A = ( L 0 ) * Q,
!! where:
!! Q is a n-by-N orthogonal matrix, stored on exit in an implicit
!! form in the elements above the diagonal of the array A and in
!! the elements of the array T;
!! L is a lower-triangular M-by-M matrix stored on exit in
!! the elements on and below the diagonal of the array A.
!! 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ii, kk, ctr
! External Subroutines
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n<m ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>m .and. m>0_${ik}$ )) then
info = -3_${ik}$
else if( nb<=0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldt<mb ) then
info = -8_${ik}$
else if( ( lwork<m*mb) .and. (.not.lquery) ) then
info = -10_${ik}$
end if
if( info==0_${ik}$) then
work(1_${ik}$) = mb*m
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLASWLQ', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( min(m,n)==0_${ik}$ ) then
return
end if
! the lq decomposition
if((m>=n).or.(nb<=m).or.(nb>=n)) then
call stdlib${ii}$_cgelqt( m, n, mb, a, lda, t, ldt, work, info)
return
end if
kk = mod((n-m),(nb-m))
ii=n-kk+1
! compute the lq factorization of the first block a(1:m,1:nb)
call stdlib${ii}$_cgelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info)
ctr = 1_${ik}$
do i = nb+1, ii-nb+m , (nb-m)
! compute the qr factorization of the current block a(1:m,i:i+nb-m)
call stdlib${ii}$_ctplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$,ctr*m+1),ldt, &
work, info )
ctr = ctr + 1_${ik}$
end do
! compute the qr factorization of the last block a(1:m,ii:n)
if (ii<=n) then
call stdlib${ii}$_ctplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$,ctr*m+1), ldt,&
work, info )
end if
work( 1_${ik}$ ) = m * mb
return
end subroutine stdlib${ii}$_claswlq
pure module subroutine stdlib${ii}$_zlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info)
!! ZLASWLQ computes a blocked Tall-Skinny LQ factorization of
!! a complexx M-by-N matrix A for M <= N:
!! A = ( L 0 ) * Q,
!! where:
!! Q is a n-by-N orthogonal matrix, stored on exit in an implicit
!! form in the elements above the diagonal of the array A and in
!! the elements of the array T;
!! L is a lower-triangular M-by-M matrix stored on exit in
!! the elements on and below the diagonal of the array A.
!! 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ii, kk, ctr
! External Subroutines
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n<m ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>m .and. m>0_${ik}$ )) then
info = -3_${ik}$
else if( nb<=0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldt<mb ) then
info = -8_${ik}$
else if( ( lwork<m*mb) .and. (.not.lquery) ) then
info = -10_${ik}$
end if
if( info==0_${ik}$) then
work(1_${ik}$) = mb*m
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLASWLQ', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( min(m,n)==0_${ik}$ ) then
return
end if
! the lq decomposition
if((m>=n).or.(nb<=m).or.(nb>=n)) then
call stdlib${ii}$_zgelqt( m, n, mb, a, lda, t, ldt, work, info)
return
end if
kk = mod((n-m),(nb-m))
ii=n-kk+1
! compute the lq factorization of the first block a(1:m,1:nb)
call stdlib${ii}$_zgelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info)
ctr = 1_${ik}$
do i = nb+1, ii-nb+m , (nb-m)
! compute the qr factorization of the current block a(1:m,i:i+nb-m)
call stdlib${ii}$_ztplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),&
ldt, work, info )
ctr = ctr + 1_${ik}$
end do
! compute the qr factorization of the last block a(1:m,ii:n)
if (ii<=n) then
call stdlib${ii}$_ztplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), &
ldt,work, info )
end if
work( 1_${ik}$ ) = m * mb
return
end subroutine stdlib${ii}$_zlaswlq
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info)
!! ZLASWLQ: computes a blocked Tall-Skinny LQ factorization of
!! a complexx M-by-N matrix A for M <= N:
!! A = ( L 0 ) * Q,
!! where:
!! Q is a n-by-N orthogonal matrix, stored on exit in an implicit
!! form in the elements above the diagonal of the array A and in
!! the elements of the array T;
!! L is a lower-triangular M-by-M matrix stored on exit in
!! the elements on and below the diagonal of the array A.
!! 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ii, kk, ctr
! External Subroutines
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n<m ) then
info = -2_${ik}$
else if( mb<1_${ik}$ .or. ( mb>m .and. m>0_${ik}$ )) then
info = -3_${ik}$
else if( nb<=0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldt<mb ) then
info = -8_${ik}$
else if( ( lwork<m*mb) .and. (.not.lquery) ) then
info = -10_${ik}$
end if
if( info==0_${ik}$) then
work(1_${ik}$) = mb*m
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLASWLQ', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( min(m,n)==0_${ik}$ ) then
return
end if
! the lq decomposition
if((m>=n).or.(nb<=m).or.(nb>=n)) then
call stdlib${ii}$_${ci}$gelqt( m, n, mb, a, lda, t, ldt, work, info)
return
end if
kk = mod((n-m),(nb-m))
ii=n-kk+1
! compute the lq factorization of the first block a(1:m,1:nb)
call stdlib${ii}$_${ci}$gelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info)
ctr = 1_${ik}$
do i = nb+1, ii-nb+m , (nb-m)
! compute the qr factorization of the current block a(1:m,i:i+nb-m)
call stdlib${ii}$_${ci}$tplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),&
ldt, work, info )
ctr = ctr + 1_${ik}$
end do
! compute the qr factorization of the last block a(1:m,ii:n)
if (ii<=n) then
call stdlib${ii}$_${ci}$tplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), &
ldt,work, info )
end if
work( 1_${ik}$ ) = m * mb
return
end subroutine stdlib${ii}$_${ci}$laswlq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, &
!! SLAMSWLQ 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 defined as the product of blocked
!! elementary reflectors computed by short wide LQ
!! factorization (SLASWLQ)
lwork, 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc
! Array Arguments
real(sp), intent(in) :: a(lda,*), t(ldt,*)
real(sp), intent(out) :: work(*)
real(sp), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: i, ii, kk, lw, ctr
! External Subroutines
! Executable Statements
! test the input arguments
lquery = lwork<0_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'T' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
if (left) then
lw = n * mb
else
lw = m * mb
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( m<k ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<mb .or. mb<1_${ik}$) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -9_${ik}$
else if( ldt<max( 1_${ik}$, mb) ) then
info = -11_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -13_${ik}$
else if(( lwork<max(1_${ik}$,lw)).and.(.not.lquery)) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAMSWLQ', -info )
work(1_${ik}$) = lw
return
else if (lquery) then
work(1_${ik}$) = lw
return
end if
! quick return if possible
if( min(m,n,k)==0_${ik}$ ) then
return
end if
if((nb<=k).or.(nb>=max(m,n,k))) then
call stdlib${ii}$_sgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info)
return
end if
if(left.and.tran) then
! multiply q to the last block of c
kk = mod((m-k),(nb-k))
ctr = (m-k)/(nb-k)
if (kk>0_${ik}$) then
ii=m-kk+1
call stdlib${ii}$_stpmlqt('L','T',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
else
ii=m+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+nb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_stpmlqt('L','T',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:nb)
call stdlib${ii}$_sgemlqt('L','T',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (left.and.notran) then
! multiply q to the first block of c
kk = mod((m-k),(nb-k))
ii=m-kk+1
ctr = 1_${ik}$
call stdlib${ii}$_sgemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (i:i+nb,1:n)
call stdlib${ii}$_stpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr * k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=m) then
! multiply q to the last block of c
call stdlib${ii}$_stpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
end if
else if(right.and.notran) then
! multiply q to the last block of c
kk = mod((n-k),(nb-k))
ctr = (n-k)/(nb-k)
if (kk>0_${ik}$) then
ii=n-kk+1
call stdlib${ii}$_stpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info )
else
ii=n+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_stpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$,ctr*k+1), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:mb)
call stdlib${ii}$_sgemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (right.and.tran) then
! multiply q to the first block of c
kk = mod((n-k),(nb-k))
ii=n-kk+1
ctr = 1_${ik}$
call stdlib${ii}$_sgemlqt('R','T',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
call stdlib${ii}$_stpmlqt('R','T',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=n) then
! multiply q to the last block of c
call stdlib${ii}$_stpmlqt('R','T',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$),&
ldc,c(1_${ik}$,ii), ldc, work, info )
end if
end if
work(1_${ik}$) = lw
return
end subroutine stdlib${ii}$_slamswlq
pure module subroutine stdlib${ii}$_dlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, &
!! DLAMSWLQ 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 defined as the product of blocked
!! elementary reflectors computed by short wide LQ
!! factorization (DLASWLQ)
lwork, 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc
! Array Arguments
real(dp), intent(in) :: a(lda,*), t(ldt,*)
real(dp), intent(out) :: work(*)
real(dp), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: i, ii, kk, ctr, lw
! External Subroutines
! Executable Statements
! test the input arguments
lquery = lwork<0_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'T' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
if (left) then
lw = n * mb
else
lw = m * mb
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( m<k ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<mb .or. mb<1_${ik}$) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -9_${ik}$
else if( ldt<max( 1_${ik}$, mb) ) then
info = -11_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -13_${ik}$
else if(( lwork<max(1_${ik}$,lw)).and.(.not.lquery)) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAMSWLQ', -info )
work(1_${ik}$) = lw
return
else if (lquery) then
work(1_${ik}$) = lw
return
end if
! quick return if possible
if( min(m,n,k)==0_${ik}$ ) then
return
end if
if((nb<=k).or.(nb>=max(m,n,k))) then
call stdlib${ii}$_dgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info)
return
end if
if(left.and.tran) then
! multiply q to the last block of c
kk = mod((m-k),(nb-k))
ctr = (m-k)/(nb-k)
if (kk>0_${ik}$) then
ii=m-kk+1
call stdlib${ii}$_dtpmlqt('L','T',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
else
ii=m+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+nb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_dtpmlqt('L','T',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr*k+1),ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:nb)
call stdlib${ii}$_dgemlqt('L','T',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (left.and.notran) then
! multiply q to the first block of c
kk = mod((m-k),(nb-k))
ii=m-kk+1
ctr = 1_${ik}$
call stdlib${ii}$_dgemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (i:i+nb,1:n)
call stdlib${ii}$_dtpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=m) then
! multiply q to the last block of c
call stdlib${ii}$_dtpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
end if
else if(right.and.notran) then
! multiply q to the last block of c
kk = mod((n-k),(nb-k))
ctr = (n-k)/(nb-k)
if (kk>0_${ik}$) then
ii=n-kk+1
call stdlib${ii}$_dtpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$,ctr *k+1), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info )
else
ii=n+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_dtpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$,ctr*k+1), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:mb)
call stdlib${ii}$_dgemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (right.and.tran) then
! multiply q to the first block of c
kk = mod((n-k),(nb-k))
ctr = 1_${ik}$
ii=n-kk+1
call stdlib${ii}$_dgemlqt('R','T',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
call stdlib${ii}$_dtpmlqt('R','T',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=n) then
! multiply q to the last block of c
call stdlib${ii}$_dtpmlqt('R','T',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$),&
ldc,c(1_${ik}$,ii), ldc, work, info )
end if
end if
work(1_${ik}$) = lw
return
end subroutine stdlib${ii}$_dlamswlq
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, &
!! DLAMSWLQ: 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 defined as the product of blocked
!! elementary reflectors computed by short wide LQ
!! factorization (DLASWLQ)
lwork, 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), t(ldt,*)
real(${rk}$), intent(out) :: work(*)
real(${rk}$), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: i, ii, kk, ctr, lw
! External Subroutines
! Executable Statements
! test the input arguments
lquery = lwork<0_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'T' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
if (left) then
lw = n * mb
else
lw = m * mb
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( m<k ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<mb .or. mb<1_${ik}$) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -9_${ik}$
else if( ldt<max( 1_${ik}$, mb) ) then
info = -11_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -13_${ik}$
else if(( lwork<max(1_${ik}$,lw)).and.(.not.lquery)) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAMSWLQ', -info )
work(1_${ik}$) = lw
return
else if (lquery) then
work(1_${ik}$) = lw
return
end if
! quick return if possible
if( min(m,n,k)==0_${ik}$ ) then
return
end if
if((nb<=k).or.(nb>=max(m,n,k))) then
call stdlib${ii}$_${ri}$gemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info)
return
end if
if(left.and.tran) then
! multiply q to the last block of c
kk = mod((m-k),(nb-k))
ctr = (m-k)/(nb-k)
if (kk>0_${ik}$) then
ii=m-kk+1
call stdlib${ii}$_${ri}$tpmlqt('L','T',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
else
ii=m+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+nb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_${ri}$tpmlqt('L','T',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr*k+1),ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:nb)
call stdlib${ii}$_${ri}$gemlqt('L','T',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (left.and.notran) then
! multiply q to the first block of c
kk = mod((m-k),(nb-k))
ii=m-kk+1
ctr = 1_${ik}$
call stdlib${ii}$_${ri}$gemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (i:i+nb,1:n)
call stdlib${ii}$_${ri}$tpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=m) then
! multiply q to the last block of c
call stdlib${ii}$_${ri}$tpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
end if
else if(right.and.notran) then
! multiply q to the last block of c
kk = mod((n-k),(nb-k))
ctr = (n-k)/(nb-k)
if (kk>0_${ik}$) then
ii=n-kk+1
call stdlib${ii}$_${ri}$tpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$,ctr *k+1), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info )
else
ii=n+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_${ri}$tpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$,ctr*k+1), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:mb)
call stdlib${ii}$_${ri}$gemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (right.and.tran) then
! multiply q to the first block of c
kk = mod((n-k),(nb-k))
ctr = 1_${ik}$
ii=n-kk+1
call stdlib${ii}$_${ri}$gemlqt('R','T',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
call stdlib${ii}$_${ri}$tpmlqt('R','T',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=n) then
! multiply q to the last block of c
call stdlib${ii}$_${ri}$tpmlqt('R','T',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$),&
ldc,c(1_${ik}$,ii), ldc, work, info )
end if
end if
work(1_${ik}$) = lw
return
end subroutine stdlib${ii}$_${ri}$lamswlq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, &
!! CLAMSWLQ overwrites the general complex M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'T': Q**H * C C * Q**H
!! where Q is a complex unitary matrix defined as the product of blocked
!! elementary reflectors computed by short wide LQ
!! factorization (CLASWLQ)
lwork, 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc
! Array Arguments
complex(sp), intent(in) :: a(lda,*), t(ldt,*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: i, ii, kk, lw, ctr
! External Subroutines
! Executable Statements
! test the input arguments
lquery = lwork<0_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'C' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
if (left) then
lw = n * mb
else
lw = m * mb
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( m<k ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<mb .or. mb<1_${ik}$) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -9_${ik}$
else if( ldt<max( 1_${ik}$, mb) ) then
info = -11_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -13_${ik}$
else if(( lwork<max(1_${ik}$,lw)).and.(.not.lquery)) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLAMSWLQ', -info )
work(1_${ik}$) = lw
return
else if (lquery) then
work(1_${ik}$) = lw
return
end if
! quick return if possible
if( min(m,n,k)==0_${ik}$ ) then
return
end if
if((nb<=k).or.(nb>=max(m,n,k))) then
call stdlib${ii}$_cgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info)
return
end if
if(left.and.tran) then
! multiply q to the last block of c
kk = mod((m-k),(nb-k))
ctr = (m-k)/(nb-k)
if (kk>0_${ik}$) then
ii=m-kk+1
call stdlib${ii}$_ctpmlqt('L','C',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
else
ii=m+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+nb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_ctpmlqt('L','C',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:nb)
call stdlib${ii}$_cgemlqt('L','C',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (left.and.notran) then
! multiply q to the first block of c
kk = mod((m-k),(nb-k))
ii = m-kk+1
ctr = 1_${ik}$
call stdlib${ii}$_cgemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (i:i+nb,1:n)
call stdlib${ii}$_ctpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr *k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=m) then
! multiply q to the last block of c
call stdlib${ii}$_ctpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
end if
else if(right.and.notran) then
! multiply q to the last block of c
kk = mod((n-k),(nb-k))
ctr = (n-k)/(nb-k)
if (kk>0_${ik}$) then
ii=n-kk+1
call stdlib${ii}$_ctpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info )
else
ii=n+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_ctpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$,ctr*k+1), ldt,&
c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:mb)
call stdlib${ii}$_cgemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (right.and.tran) then
! multiply q to the first block of c
kk = mod((n-k),(nb-k))
ii=n-kk+1
ctr = 1_${ik}$
call stdlib${ii}$_cgemlqt('R','C',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
call stdlib${ii}$_ctpmlqt('R','C',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=n) then
! multiply q to the last block of c
call stdlib${ii}$_ctpmlqt('R','C',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$),&
ldc,c(1_${ik}$,ii), ldc, work, info )
end if
end if
work(1_${ik}$) = lw
return
end subroutine stdlib${ii}$_clamswlq
pure module subroutine stdlib${ii}$_zlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, &
!! ZLAMSWLQ 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 defined as the product of blocked
!! elementary reflectors computed by short wide LQ
!! factorization (ZLASWLQ)
lwork, 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc
! Array Arguments
complex(dp), intent(in) :: a(lda,*), t(ldt,*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: i, ii, kk, lw, ctr
! External Subroutines
! Executable Statements
! test the input arguments
lquery = lwork<0_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'C' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
if (left) then
lw = n * mb
else
lw = m * mb
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( m<k ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<mb .or. mb<1_${ik}$) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -9_${ik}$
else if( ldt<max( 1_${ik}$, mb) ) then
info = -11_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -13_${ik}$
else if(( lwork<max(1_${ik}$,lw)).and.(.not.lquery)) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAMSWLQ', -info )
work(1_${ik}$) = lw
return
else if (lquery) then
work(1_${ik}$) = lw
return
end if
! quick return if possible
if( min(m,n,k)==0_${ik}$ ) then
return
end if
if((nb<=k).or.(nb>=max(m,n,k))) then
call stdlib${ii}$_zgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info)
return
end if
if(left.and.tran) then
! multiply q to the last block of c
kk = mod((m-k),(nb-k))
ctr = (m-k)/(nb-k)
if (kk>0_${ik}$) then
ii=m-kk+1
call stdlib${ii}$_ztpmlqt('L','C',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
else
ii=m+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+nb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_ztpmlqt('L','C',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:nb)
call stdlib${ii}$_zgemlqt('L','C',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (left.and.notran) then
! multiply q to the first block of c
kk = mod((m-k),(nb-k))
ii=m-kk+1
ctr = 1_${ik}$
call stdlib${ii}$_zgemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (i:i+nb,1:n)
call stdlib${ii}$_ztpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=m) then
! multiply q to the last block of c
call stdlib${ii}$_ztpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
end if
else if(right.and.notran) then
! multiply q to the last block of c
kk = mod((n-k),(nb-k))
ctr = (n-k)/(nb-k)
if (kk>0_${ik}$) then
ii=n-kk+1
call stdlib${ii}$_ztpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$), &
ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info )
else
ii=n+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_ztpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$, ctr * k + 1_${ik}$), &
ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:mb)
call stdlib${ii}$_zgemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (right.and.tran) then
! multiply q to the first block of c
kk = mod((n-k),(nb-k))
ii=n-kk+1
call stdlib${ii}$_zgemlqt('R','C',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
ctr = 1_${ik}$
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
call stdlib${ii}$_ztpmlqt('R','C',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr *k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=n) then
! multiply q to the last block of c
call stdlib${ii}$_ztpmlqt('R','C',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info )
end if
end if
work(1_${ik}$) = lw
return
end subroutine stdlib${ii}$_zlamswlq
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, &
!! ZLAMSWLQ: 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 defined as the product of blocked
!! elementary reflectors computed by short wide LQ
!! factorization (ZLASWLQ)
lwork, 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(out) :: info
integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), t(ldt,*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran, lquery
integer(${ik}$) :: i, ii, kk, lw, ctr
! External Subroutines
! Executable Statements
! test the input arguments
lquery = lwork<0_${ik}$
notran = stdlib_lsame( trans, 'N' )
tran = stdlib_lsame( trans, 'C' )
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
if (left) then
lw = n * mb
else
lw = m * mb
end if
info = 0_${ik}$
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( m<k ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<mb .or. mb<1_${ik}$) then
info = -6_${ik}$
else if( lda<max( 1_${ik}$, k ) ) then
info = -9_${ik}$
else if( ldt<max( 1_${ik}$, mb) ) then
info = -11_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -13_${ik}$
else if(( lwork<max(1_${ik}$,lw)).and.(.not.lquery)) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAMSWLQ', -info )
work(1_${ik}$) = lw
return
else if (lquery) then
work(1_${ik}$) = lw
return
end if
! quick return if possible
if( min(m,n,k)==0_${ik}$ ) then
return
end if
if((nb<=k).or.(nb>=max(m,n,k))) then
call stdlib${ii}$_${ci}$gemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info)
return
end if
if(left.and.tran) then
! multiply q to the last block of c
kk = mod((m-k),(nb-k))
ctr = (m-k)/(nb-k)
if (kk>0_${ik}$) then
ii=m-kk+1
call stdlib${ii}$_${ci}$tpmlqt('L','C',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
else
ii=m+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+nb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_${ci}$tpmlqt('L','C',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:nb)
call stdlib${ii}$_${ci}$gemlqt('L','C',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (left.and.notran) then
! multiply q to the first block of c
kk = mod((m-k),(nb-k))
ii=m-kk+1
ctr = 1_${ik}$
call stdlib${ii}$_${ci}$gemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (i:i+nb,1:n)
call stdlib${ii}$_${ci}$tpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=m) then
! multiply q to the last block of c
call stdlib${ii}$_${ci}$tpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, &
c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info )
end if
else if(right.and.notran) then
! multiply q to the last block of c
kk = mod((n-k),(nb-k))
ctr = (n-k)/(nb-k)
if (kk>0_${ik}$) then
ii=n-kk+1
call stdlib${ii}$_${ci}$tpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$), &
ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info )
else
ii=n+1
end if
do i=ii-(nb-k),nb+1,-(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
ctr = ctr - 1_${ik}$
call stdlib${ii}$_${ci}$tpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$, ctr * k + 1_${ik}$), &
ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
end do
! multiply q to the first block of c (1:m,1:mb)
call stdlib${ii}$_${ci}$gemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
else if (right.and.tran) then
! multiply q to the first block of c
kk = mod((n-k),(nb-k))
ii=n-kk+1
call stdlib${ii}$_${ci}$gemlqt('R','C',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, &
info )
ctr = 1_${ik}$
do i=nb+1,ii-nb+k,(nb-k)
! multiply q to the current block of c (1:m,i:i+mb)
call stdlib${ii}$_${ci}$tpmlqt('R','C',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr *k+1), ldt, c(1_${ik}$,&
1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info )
ctr = ctr + 1_${ik}$
end do
if(ii<=n) then
! multiply q to the last block of c
call stdlib${ii}$_${ci}$tpmlqt('R','C',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, c(&
1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info )
end if
end if
work(1_${ik}$) = lw
return
end subroutine stdlib${ii}$_${ci}$lamswlq
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info )
!! STPLQT computes a blocked LQ factorization of a real
!! "triangular-pentagonal" matrix C, which is composed of a
!! triangular block A and pentagonal block B, using the compact
!! WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, mb
! Array Arguments
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, lb, nb, iinfo
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. (l>min(m,n) .and. min(m,n)>=0_${ik}$)) then
info = -3_${ik}$
else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STPLQT', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 ) return
do i = 1, m, mb
! compute the qr factorization of the current block
ib = min( m-i+1, mb )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_stplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo )
! update by applying h**t to b(i+ib:m,:) from the right
if( i+ib<=m ) then
call stdlib${ii}$_stprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( &
1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1)
end if
end do
return
end subroutine stdlib${ii}$_stplqt
pure module subroutine stdlib${ii}$_dtplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info )
!! DTPLQT computes a blocked LQ factorization of a real
!! "triangular-pentagonal" matrix C, which is composed of a
!! triangular block A and pentagonal block B, using the compact
!! WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, mb
! Array Arguments
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, lb, nb, iinfo
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. (l>min(m,n) .and. min(m,n)>=0_${ik}$)) then
info = -3_${ik}$
else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPLQT', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 ) return
do i = 1, m, mb
! compute the qr factorization of the current block
ib = min( m-i+1, mb )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_dtplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo )
! update by applying h**t to b(i+ib:m,:) from the right
if( i+ib<=m ) then
call stdlib${ii}$_dtprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( &
1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1)
end if
end do
return
end subroutine stdlib${ii}$_dtplqt
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info )
!! DTPLQT: computes a blocked LQ factorization of a real
!! "triangular-pentagonal" matrix C, which is composed of a
!! triangular block A and pentagonal block B, using the compact
!! WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, mb
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, lb, nb, iinfo
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. (l>min(m,n) .and. min(m,n)>=0_${ik}$)) then
info = -3_${ik}$
else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPLQT', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 ) return
do i = 1, m, mb
! compute the qr factorization of the current block
ib = min( m-i+1, mb )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_${ri}$tplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo )
! update by applying h**t to b(i+ib:m,:) from the right
if( i+ib<=m ) then
call stdlib${ii}$_${ri}$tprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( &
1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1)
end if
end do
return
end subroutine stdlib${ii}$_${ri}$tplqt
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info )
!! CTPLQT computes a blocked LQ factorization of a complex
!! "triangular-pentagonal" matrix C, which is composed of a
!! triangular block A and pentagonal block B, using the compact
!! WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, mb
! Array Arguments
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, lb, nb, iinfo
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. (l>min(m,n) .and. min(m,n)>=0_${ik}$)) then
info = -3_${ik}$
else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTPLQT', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 ) return
do i = 1, m, mb
! compute the qr factorization of the current block
ib = min( m-i+1, mb )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_ctplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo )
! update by applying h**t to b(i+ib:m,:) from the right
if( i+ib<=m ) then
call stdlib${ii}$_ctprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( &
1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1)
end if
end do
return
end subroutine stdlib${ii}$_ctplqt
pure module subroutine stdlib${ii}$_ztplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info )
!! ZTPLQT computes a blocked LQ factorization of a complex
!! "triangular-pentagonal" matrix C, which is composed of a
!! triangular block A and pentagonal block B, using the compact
!! WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, mb
! Array Arguments
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, lb, nb, iinfo
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. (l>min(m,n) .and. min(m,n)>=0_${ik}$)) then
info = -3_${ik}$
else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPLQT', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 ) return
do i = 1, m, mb
! compute the qr factorization of the current block
ib = min( m-i+1, mb )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_ztplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo )
! update by applying h**t to b(i+ib:m,:) from the right
if( i+ib<=m ) then
call stdlib${ii}$_ztprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( &
1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1)
end if
end do
return
end subroutine stdlib${ii}$_ztplqt
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info )
!! ZTPLQT: computes a blocked LQ factorization of a complex
!! "triangular-pentagonal" matrix C, which is composed of a
!! triangular block A and pentagonal block B, using the compact
!! WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, mb
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: t(ldt,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ib, lb, nb, iinfo
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. (l>min(m,n) .and. min(m,n)>=0_${ik}$)) then
info = -3_${ik}$
else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -8_${ik}$
else if( ldt<mb ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPLQT', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 ) return
do i = 1, m, mb
! compute the qr factorization of the current block
ib = min( m-i+1, mb )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_${ci}$tplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo )
! update by applying h**t to b(i+ib:m,:) from the right
if( i+ib<=m ) then
call stdlib${ii}$_${ci}$tprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( &
1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1)
end if
end do
return
end subroutine stdlib${ii}$_${ci}$tplqt
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stplqt2( m, n, l, a, lda, b, ldb, t, ldt, info )
!! STPLQT2 computes a LQ a factorization of a real "triangular-pentagonal"
!! matrix C, which is composed of a triangular block A and pentagonal block B,
!! using the compact WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l
! Array Arguments
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, p, mp, np
real(sp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. l>min(m,n) ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldt<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STPLQT2', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 ) return
do i = 1, m
! generate elementary reflector h(i) to annihilate b(i,:)
p = n-l+min( l, i )
call stdlib${ii}$_slarfg( p+1, a( i, i ), b( i, 1_${ik}$ ), ldb, t( 1_${ik}$, i ) )
if( i<m ) then
! w(m-i:1) := c(i+1:m,i:n) * c(i,i:n) [use w = t(m,:)]
do j = 1, m-i
t( m, j ) = (a( i+j, i ))
end do
call stdlib${ii}$_sgemv( 'N', m-i, p, one, b( i+1, 1_${ik}$ ), ldb,b( i, 1_${ik}$ ), ldb, one, t( m, &
1_${ik}$ ), ldt )
! c(i+1:m,i:n) = c(i+1:m,i:n) + alpha * c(i,i:n)*w(m-1:1)^h
alpha = -(t( 1_${ik}$, i ))
do j = 1, m-i
a( i+j, i ) = a( i+j, i ) + alpha*(t( m, j ))
end do
call stdlib${ii}$_sger( m-i, p, alpha, t( m, 1_${ik}$ ), ldt,b( i, 1_${ik}$ ), ldb, b( i+1, 1_${ik}$ ), &
ldb )
end if
end do
do i = 2, m
! t(i,1:i-1) := c(i:i-1,1:n) * (alpha * c(i,i:n)^h)
alpha = -t( 1_${ik}$, i )
do j = 1, i-1
t( i, j ) = zero
end do
p = min( i-1, l )
np = min( n-l+1, n )
mp = min( p+1, m )
! triangular part of b2
do j = 1, p
t( i, j ) = alpha*b( i, n-l+j )
end do
call stdlib${ii}$_strmv( 'L', 'N', 'N', p, b( 1_${ik}$, np ), ldb,t( i, 1_${ik}$ ), ldt )
! rectangular part of b2
call stdlib${ii}$_sgemv( 'N', i-1-p, l, alpha, b( mp, np ), ldb,b( i, np ), ldb, zero, t(&
i,mp ), ldt )
! b1
call stdlib${ii}$_sgemv( 'N', i-1, n-l, alpha, b, ldb, b( i, 1_${ik}$ ), ldb,one, t( i, 1_${ik}$ ), ldt &
)
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(i,1:i-1)
call stdlib${ii}$_strmv( 'L', 'T', 'N', i-1, t, ldt, t( i, 1_${ik}$ ), ldt )
! t(i,i) = tau(i)
t( i, i ) = t( 1_${ik}$, i )
t( 1_${ik}$, i ) = zero
end do
do i=1,m
do j= i+1,m
t(i,j)=t(j,i)
t(j,i)= zero
end do
end do
end subroutine stdlib${ii}$_stplqt2
pure module subroutine stdlib${ii}$_dtplqt2( m, n, l, a, lda, b, ldb, t, ldt, info )
!! DTPLQT2 computes a LQ a factorization of a real "triangular-pentagonal"
!! matrix C, which is composed of a triangular block A and pentagonal block B,
!! using the compact WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l
! Array Arguments
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, p, mp, np
real(dp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. l>min(m,n) ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldt<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPLQT2', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 ) return
do i = 1, m
! generate elementary reflector h(i) to annihilate b(i,:)
p = n-l+min( l, i )
call stdlib${ii}$_dlarfg( p+1, a( i, i ), b( i, 1_${ik}$ ), ldb, t( 1_${ik}$, i ) )
if( i<m ) then
! w(m-i:1) := c(i+1:m,i:n) * c(i,i:n) [use w = t(m,:)]
do j = 1, m-i
t( m, j ) = (a( i+j, i ))
end do
call stdlib${ii}$_dgemv( 'N', m-i, p, one, b( i+1, 1_${ik}$ ), ldb,b( i, 1_${ik}$ ), ldb, one, t( m, &
1_${ik}$ ), ldt )
! c(i+1:m,i:n) = c(i+1:m,i:n) + alpha * c(i,i:n)*w(m-1:1)^h
alpha = -(t( 1_${ik}$, i ))
do j = 1, m-i
a( i+j, i ) = a( i+j, i ) + alpha*(t( m, j ))
end do
call stdlib${ii}$_dger( m-i, p, alpha, t( m, 1_${ik}$ ), ldt,b( i, 1_${ik}$ ), ldb, b( i+1, 1_${ik}$ ), &
ldb )
end if
end do
do i = 2, m
! t(i,1:i-1) := c(i:i-1,1:n) * (alpha * c(i,i:n)^h)
alpha = -t( 1_${ik}$, i )
do j = 1, i-1
t( i, j ) = zero
end do
p = min( i-1, l )
np = min( n-l+1, n )
mp = min( p+1, m )
! triangular part of b2
do j = 1, p
t( i, j ) = alpha*b( i, n-l+j )
end do
call stdlib${ii}$_dtrmv( 'L', 'N', 'N', p, b( 1_${ik}$, np ), ldb,t( i, 1_${ik}$ ), ldt )
! rectangular part of b2
call stdlib${ii}$_dgemv( 'N', i-1-p, l, alpha, b( mp, np ), ldb,b( i, np ), ldb, zero, t(&
i,mp ), ldt )
! b1
call stdlib${ii}$_dgemv( 'N', i-1, n-l, alpha, b, ldb, b( i, 1_${ik}$ ), ldb,one, t( i, 1_${ik}$ ), ldt &
)
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(i,1:i-1)
call stdlib${ii}$_dtrmv( 'L', 'T', 'N', i-1, t, ldt, t( i, 1_${ik}$ ), ldt )
! t(i,i) = tau(i)
t( i, i ) = t( 1_${ik}$, i )
t( 1_${ik}$, i ) = zero
end do
do i=1,m
do j= i+1,m
t(i,j)=t(j,i)
t(j,i)= zero
end do
end do
end subroutine stdlib${ii}$_dtplqt2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tplqt2( m, n, l, a, lda, b, ldb, t, ldt, info )
!! DTPLQT2: computes a LQ a factorization of a real "triangular-pentagonal"
!! matrix C, which is composed of a triangular block A and pentagonal block B,
!! using the compact WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, p, mp, np
real(${rk}$) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. l>min(m,n) ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldt<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPLQT2', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 ) return
do i = 1, m
! generate elementary reflector h(i) to annihilate b(i,:)
p = n-l+min( l, i )
call stdlib${ii}$_${ri}$larfg( p+1, a( i, i ), b( i, 1_${ik}$ ), ldb, t( 1_${ik}$, i ) )
if( i<m ) then
! w(m-i:1) := c(i+1:m,i:n) * c(i,i:n) [use w = t(m,:)]
do j = 1, m-i
t( m, j ) = (a( i+j, i ))
end do
call stdlib${ii}$_${ri}$gemv( 'N', m-i, p, one, b( i+1, 1_${ik}$ ), ldb,b( i, 1_${ik}$ ), ldb, one, t( m, &
1_${ik}$ ), ldt )
! c(i+1:m,i:n) = c(i+1:m,i:n) + alpha * c(i,i:n)*w(m-1:1)^h
alpha = -(t( 1_${ik}$, i ))
do j = 1, m-i
a( i+j, i ) = a( i+j, i ) + alpha*(t( m, j ))
end do
call stdlib${ii}$_${ri}$ger( m-i, p, alpha, t( m, 1_${ik}$ ), ldt,b( i, 1_${ik}$ ), ldb, b( i+1, 1_${ik}$ ), &
ldb )
end if
end do
do i = 2, m
! t(i,1:i-1) := c(i:i-1,1:n) * (alpha * c(i,i:n)^h)
alpha = -t( 1_${ik}$, i )
do j = 1, i-1
t( i, j ) = zero
end do
p = min( i-1, l )
np = min( n-l+1, n )
mp = min( p+1, m )
! triangular part of b2
do j = 1, p
t( i, j ) = alpha*b( i, n-l+j )
end do
call stdlib${ii}$_${ri}$trmv( 'L', 'N', 'N', p, b( 1_${ik}$, np ), ldb,t( i, 1_${ik}$ ), ldt )
! rectangular part of b2
call stdlib${ii}$_${ri}$gemv( 'N', i-1-p, l, alpha, b( mp, np ), ldb,b( i, np ), ldb, zero, t(&
i,mp ), ldt )
! b1
call stdlib${ii}$_${ri}$gemv( 'N', i-1, n-l, alpha, b, ldb, b( i, 1_${ik}$ ), ldb,one, t( i, 1_${ik}$ ), ldt &
)
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(i,1:i-1)
call stdlib${ii}$_${ri}$trmv( 'L', 'T', 'N', i-1, t, ldt, t( i, 1_${ik}$ ), ldt )
! t(i,i) = tau(i)
t( i, i ) = t( 1_${ik}$, i )
t( 1_${ik}$, i ) = zero
end do
do i=1,m
do j= i+1,m
t(i,j)=t(j,i)
t(j,i)= zero
end do
end do
end subroutine stdlib${ii}$_${ri}$tplqt2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctplqt2( m, n, l, a, lda, b, ldb, t, ldt, info )
!! CTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal"
!! matrix C, which is composed of a triangular block A and pentagonal block B,
!! using the compact WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l
! Array Arguments
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, p, mp, np
complex(sp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. l>min(m,n) ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldt<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTPLQT2', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 ) return
do i = 1, m
! generate elementary reflector h(i) to annihilate b(i,:)
p = n-l+min( l, i )
call stdlib${ii}$_clarfg( p+1, a( i, i ), b( i, 1_${ik}$ ), ldb, t( 1_${ik}$, i ) )
t(1_${ik}$,i)=conjg(t(1_${ik}$,i))
if( i<m ) then
do j = 1, p
b( i, j ) = conjg(b(i,j))
end do
! w(m-i:1) := c(i+1:m,i:n) * c(i,i:n) [use w = t(m,:)]
do j = 1, m-i
t( m, j ) = (a( i+j, i ))
end do
call stdlib${ii}$_cgemv( 'N', m-i, p, cone, b( i+1, 1_${ik}$ ), ldb,b( i, 1_${ik}$ ), ldb, cone, t( &
m, 1_${ik}$ ), ldt )
! c(i+1:m,i:n) = c(i+1:m,i:n) + alpha * c(i,i:n)*w(m-1:1)^h
alpha = -(t( 1_${ik}$, i ))
do j = 1, m-i
a( i+j, i ) = a( i+j, i ) + alpha*(t( m, j ))
end do
call stdlib${ii}$_cgerc( m-i, p, (alpha), t( m, 1_${ik}$ ), ldt,b( i, 1_${ik}$ ), ldb, b( i+1, 1_${ik}$ ), &
ldb )
do j = 1, p
b( i, j ) = conjg(b(i,j))
end do
end if
end do
do i = 2, m
! t(i,1:i-1) := c(i:i-1,1:n)**h * (alpha * c(i,i:n))
alpha = -(t( 1_${ik}$, i ))
do j = 1, i-1
t( i, j ) = czero
end do
p = min( i-1, l )
np = min( n-l+1, n )
mp = min( p+1, m )
do j = 1, n-l+p
b(i,j)=conjg(b(i,j))
end do
! triangular part of b2
do j = 1, p
t( i, j ) = (alpha*b( i, n-l+j ))
end do
call stdlib${ii}$_ctrmv( 'L', 'N', 'N', p, b( 1_${ik}$, np ), ldb,t( i, 1_${ik}$ ), ldt )
! rectangular part of b2
call stdlib${ii}$_cgemv( 'N', i-1-p, l, alpha, b( mp, np ), ldb,b( i, np ), ldb, czero, &
t( i,mp ), ldt )
! b1
call stdlib${ii}$_cgemv( 'N', i-1, n-l, alpha, b, ldb, b( i, 1_${ik}$ ), ldb,cone, t( i, 1_${ik}$ ), &
ldt )
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(i,1:i-1)
do j = 1, i-1
t(i,j)=conjg(t(i,j))
end do
call stdlib${ii}$_ctrmv( 'L', 'C', 'N', i-1, t, ldt, t( i, 1_${ik}$ ), ldt )
do j = 1, i-1
t(i,j)=conjg(t(i,j))
end do
do j = 1, n-l+p
b(i,j)=conjg(b(i,j))
end do
! t(i,i) = tau(i)
t( i, i ) = t( 1_${ik}$, i )
t( 1_${ik}$, i ) = czero
end do
do i=1,m
do j= i+1,m
t(i,j)=(t(j,i))
t(j,i)=czero
end do
end do
end subroutine stdlib${ii}$_ctplqt2
pure module subroutine stdlib${ii}$_ztplqt2( m, n, l, a, lda, b, ldb, t, ldt, info )
!! ZTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal"
!! matrix C, which is composed of a triangular block A and pentagonal block B,
!! using the compact WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l
! Array Arguments
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, p, mp, np
complex(dp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. l>min(m,n) ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldt<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPLQT2', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 ) return
do i = 1, m
! generate elementary reflector h(i) to annihilate b(i,:)
p = n-l+min( l, i )
call stdlib${ii}$_zlarfg( p+1, a( i, i ), b( i, 1_${ik}$ ), ldb, t( 1_${ik}$, i ) )
t(1_${ik}$,i)=conjg(t(1_${ik}$,i))
if( i<m ) then
do j = 1, p
b( i, j ) = conjg(b(i,j))
end do
! w(m-i:1) := c(i+1:m,i:n) * c(i,i:n) [use w = t(m,:)]
do j = 1, m-i
t( m, j ) = (a( i+j, i ))
end do
call stdlib${ii}$_zgemv( 'N', m-i, p, cone, b( i+1, 1_${ik}$ ), ldb,b( i, 1_${ik}$ ), ldb, cone, t( &
m, 1_${ik}$ ), ldt )
! c(i+1:m,i:n) = c(i+1:m,i:n) + alpha * c(i,i:n)*w(m-1:1)^h
alpha = -(t( 1_${ik}$, i ))
do j = 1, m-i
a( i+j, i ) = a( i+j, i ) + alpha*(t( m, j ))
end do
call stdlib${ii}$_zgerc( m-i, p, (alpha), t( m, 1_${ik}$ ), ldt,b( i, 1_${ik}$ ), ldb, b( i+1, 1_${ik}$ ), &
ldb )
do j = 1, p
b( i, j ) = conjg(b(i,j))
end do
end if
end do
do i = 2, m
! t(i,1:i-1) := c(i:i-1,1:n)**h * (alpha * c(i,i:n))
alpha = -(t( 1_${ik}$, i ))
do j = 1, i-1
t( i, j ) = czero
end do
p = min( i-1, l )
np = min( n-l+1, n )
mp = min( p+1, m )
do j = 1, n-l+p
b(i,j)=conjg(b(i,j))
end do
! triangular part of b2
do j = 1, p
t( i, j ) = (alpha*b( i, n-l+j ))
end do
call stdlib${ii}$_ztrmv( 'L', 'N', 'N', p, b( 1_${ik}$, np ), ldb,t( i, 1_${ik}$ ), ldt )
! rectangular part of b2
call stdlib${ii}$_zgemv( 'N', i-1-p, l, alpha, b( mp, np ), ldb,b( i, np ), ldb, czero, &
t( i,mp ), ldt )
! b1
call stdlib${ii}$_zgemv( 'N', i-1, n-l, alpha, b, ldb, b( i, 1_${ik}$ ), ldb,cone, t( i, 1_${ik}$ ), &
ldt )
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(i,1:i-1)
do j = 1, i-1
t(i,j)=conjg(t(i,j))
end do
call stdlib${ii}$_ztrmv( 'L', 'C', 'N', i-1, t, ldt, t( i, 1_${ik}$ ), ldt )
do j = 1, i-1
t(i,j)=conjg(t(i,j))
end do
do j = 1, n-l+p
b(i,j)=conjg(b(i,j))
end do
! t(i,i) = tau(i)
t( i, i ) = t( 1_${ik}$, i )
t( 1_${ik}$, i ) = czero
end do
do i=1,m
do j= i+1,m
t(i,j)=(t(j,i))
t(j,i)=czero
end do
end do
end subroutine stdlib${ii}$_ztplqt2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tplqt2( m, n, l, a, lda, b, ldb, t, ldt, info )
!! ZTPLQT2: computes a LQ a factorization of a complex "triangular-pentagonal"
!! matrix C, which is composed of a triangular block A and pentagonal block B,
!! using the compact WY representation for Q.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: t(ldt,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, p, mp, np
complex(${ck}$) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( l<0_${ik}$ .or. l>min(m,n) ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldt<max( 1_${ik}$, m ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPLQT2', -info )
return
end if
! quick return if possible
if( n==0 .or. m==0 ) return
do i = 1, m
! generate elementary reflector h(i) to annihilate b(i,:)
p = n-l+min( l, i )
call stdlib${ii}$_${ci}$larfg( p+1, a( i, i ), b( i, 1_${ik}$ ), ldb, t( 1_${ik}$, i ) )
t(1_${ik}$,i)=conjg(t(1_${ik}$,i))
if( i<m ) then
do j = 1, p
b( i, j ) = conjg(b(i,j))
end do
! w(m-i:1) := c(i+1:m,i:n) * c(i,i:n) [use w = t(m,:)]
do j = 1, m-i
t( m, j ) = (a( i+j, i ))
end do
call stdlib${ii}$_${ci}$gemv( 'N', m-i, p, cone, b( i+1, 1_${ik}$ ), ldb,b( i, 1_${ik}$ ), ldb, cone, t( &
m, 1_${ik}$ ), ldt )
! c(i+1:m,i:n) = c(i+1:m,i:n) + alpha * c(i,i:n)*w(m-1:1)^h
alpha = -(t( 1_${ik}$, i ))
do j = 1, m-i
a( i+j, i ) = a( i+j, i ) + alpha*(t( m, j ))
end do
call stdlib${ii}$_${ci}$gerc( m-i, p, (alpha), t( m, 1_${ik}$ ), ldt,b( i, 1_${ik}$ ), ldb, b( i+1, 1_${ik}$ ), &
ldb )
do j = 1, p
b( i, j ) = conjg(b(i,j))
end do
end if
end do
do i = 2, m
! t(i,1:i-1) := c(i:i-1,1:n)**h * (alpha * c(i,i:n))
alpha = -(t( 1_${ik}$, i ))
do j = 1, i-1
t( i, j ) = czero
end do
p = min( i-1, l )
np = min( n-l+1, n )
mp = min( p+1, m )
do j = 1, n-l+p
b(i,j)=conjg(b(i,j))
end do
! triangular part of b2
do j = 1, p
t( i, j ) = (alpha*b( i, n-l+j ))
end do
call stdlib${ii}$_${ci}$trmv( 'L', 'N', 'N', p, b( 1_${ik}$, np ), ldb,t( i, 1_${ik}$ ), ldt )
! rectangular part of b2
call stdlib${ii}$_${ci}$gemv( 'N', i-1-p, l, alpha, b( mp, np ), ldb,b( i, np ), ldb, czero, &
t( i,mp ), ldt )
! b1
call stdlib${ii}$_${ci}$gemv( 'N', i-1, n-l, alpha, b, ldb, b( i, 1_${ik}$ ), ldb,cone, t( i, 1_${ik}$ ), &
ldt )
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(i,1:i-1)
do j = 1, i-1
t(i,j)=conjg(t(i,j))
end do
call stdlib${ii}$_${ci}$trmv( 'L', 'C', 'N', i-1, t, ldt, t( i, 1_${ik}$ ), ldt )
do j = 1, i-1
t(i,j)=conjg(t(i,j))
end do
do j = 1, n-l+p
b(i,j)=conjg(b(i,j))
end do
! t(i,i) = tau(i)
t( i, i ) = t( 1_${ik}$, i )
t( 1_${ik}$, i ) = czero
end do
do i=1,m
do j= i+1,m
t(i,j)=(t(j,i))
t(j,i)=czero
end do
end do
end subroutine stdlib${ii}$_${ci}$tplqt2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, &
!! STPMLQT applies a real orthogonal matrix Q obtained from a
!! "triangular-pentagonal" real block reflector H to a general
!! real matrix C, which consists of two blocks A and B.
work, 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, mb, ldt
! Array Arguments
real(sp), intent(in) :: v(ldv,*), t(ldt,*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, nb, lb, kf, ldaq
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'T' )
notran = stdlib_lsame( trans, 'N' )
if ( left ) then
ldaq = max( 1_${ik}$, k )
else if ( right ) then
ldaq = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( l<0_${ik}$ .or. l>k ) then
info = -6_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then
info = -7_${ik}$
else if( ldv<k ) then
info = -9_${ik}$
else if( ldt<mb ) then
info = -11_${ik}$
else if( lda<ldaq ) then
info = -13_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STPMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_stprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_stprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_stprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_stprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
end if
return
end subroutine stdlib${ii}$_stpmlqt
pure module subroutine stdlib${ii}$_dtpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, &
!! DTPMQRT applies a real orthogonal matrix Q obtained from a
!! "triangular-pentagonal" real block reflector H to a general
!! real matrix C, which consists of two blocks A and B.
work, 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, mb, ldt
! Array Arguments
real(dp), intent(in) :: v(ldv,*), t(ldt,*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, nb, lb, kf, ldaq
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'T' )
notran = stdlib_lsame( trans, 'N' )
if ( left ) then
ldaq = max( 1_${ik}$, k )
else if ( right ) then
ldaq = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( l<0_${ik}$ .or. l>k ) then
info = -6_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then
info = -7_${ik}$
else if( ldv<k ) then
info = -9_${ik}$
else if( ldt<mb ) then
info = -11_${ik}$
else if( lda<ldaq ) then
info = -13_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_dtprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_dtprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_dtprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_dtprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
end if
return
end subroutine stdlib${ii}$_dtpmlqt
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, &
!! DTPMQRT applies a real orthogonal matrix Q obtained from a
!! "triangular-pentagonal" real block reflector H to a general
!! real matrix C, which consists of two blocks A and B.
work, 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, mb, ldt
! Array Arguments
real(${rk}$), intent(in) :: v(ldv,*), t(ldt,*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, nb, lb, kf, ldaq
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'T' )
notran = stdlib_lsame( trans, 'N' )
if ( left ) then
ldaq = max( 1_${ik}$, k )
else if ( right ) then
ldaq = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( l<0_${ik}$ .or. l>k ) then
info = -6_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then
info = -7_${ik}$
else if( ldv<k ) then
info = -9_${ik}$
else if( ldt<mb ) then
info = -11_${ik}$
else if( lda<ldaq ) then
info = -13_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_${ri}$tprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_${ri}$tprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_${ri}$tprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_${ri}$tprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
end if
return
end subroutine stdlib${ii}$_${ri}$tpmlqt
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, &
!! CTPMLQT applies a complex unitary matrix Q obtained from a
!! "triangular-pentagonal" complex block reflector H to a general
!! complex matrix C, which consists of two blocks A and B.
work, 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, mb, ldt
! Array Arguments
complex(sp), intent(in) :: v(ldv,*), t(ldt,*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, nb, lb, kf, ldaq
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'C' )
notran = stdlib_lsame( trans, 'N' )
if ( left ) then
ldaq = max( 1_${ik}$, k )
else if ( right ) then
ldaq = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( l<0_${ik}$ .or. l>k ) then
info = -6_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then
info = -7_${ik}$
else if( ldv<k ) then
info = -9_${ik}$
else if( ldt<mb ) then
info = -11_${ik}$
else if( lda<ldaq ) then
info = -13_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTPMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_ctprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_ctprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_ctprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_ctprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
end if
return
end subroutine stdlib${ii}$_ctpmlqt
pure module subroutine stdlib${ii}$_ztpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, &
!! ZTPMLQT applies a complex unitary matrix Q obtained from a
!! "triangular-pentagonal" complex block reflector H to a general
!! complex matrix C, which consists of two blocks A and B.
work, 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, mb, ldt
! Array Arguments
complex(dp), intent(in) :: v(ldv,*), t(ldt,*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, nb, lb, kf, ldaq
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'C' )
notran = stdlib_lsame( trans, 'N' )
if ( left ) then
ldaq = max( 1_${ik}$, k )
else if ( right ) then
ldaq = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( l<0_${ik}$ .or. l>k ) then
info = -6_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then
info = -7_${ik}$
else if( ldv<k ) then
info = -9_${ik}$
else if( ldt<mb ) then
info = -11_${ik}$
else if( lda<ldaq ) then
info = -13_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_ztprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_ztprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_ztprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_ztprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
end if
return
end subroutine stdlib${ii}$_ztpmlqt
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, &
!! ZTPMLQT: applies a complex unitary matrix Q obtained from a
!! "triangular-pentagonal" complex block reflector H to a general
!! complex matrix C, which consists of two blocks A and B.
work, 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(out) :: info
integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, mb, ldt
! Array Arguments
complex(${ck}$), intent(in) :: v(ldv,*), t(ldt,*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, right, tran, notran
integer(${ik}$) :: i, ib, nb, lb, kf, ldaq
! Intrinsic Functions
! Executable Statements
! Test The Input Arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
right = stdlib_lsame( side, 'R' )
tran = stdlib_lsame( trans, 'C' )
notran = stdlib_lsame( trans, 'N' )
if ( left ) then
ldaq = max( 1_${ik}$, k )
else if ( right ) then
ldaq = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.right ) then
info = -1_${ik}$
else if( .not.tran .and. .not.notran ) then
info = -2_${ik}$
else if( m<0_${ik}$ ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( k<0_${ik}$ ) then
info = -5_${ik}$
else if( l<0_${ik}$ .or. l>k ) then
info = -6_${ik}$
else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then
info = -7_${ik}$
else if( ldv<k ) then
info = -9_${ik}$
else if( ldt<mb ) then
info = -11_${ik}$
else if( lda<ldaq ) then
info = -13_${ik}$
else if( ldb<max( 1_${ik}$, m ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPMLQT', -info )
return
end if
! Quick Return If Possible
if( m==0 .or. n==0 .or. k==0 ) return
if( left .and. notran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_${ci}$tprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. tran ) then
do i = 1, k, mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_${ci}$tprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
else if( left .and. tran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( m-l+i+ib-1, m )
if( i>=l ) then
lb = 0_${ik}$
else
lb = 0_${ik}$
end if
call stdlib${ii}$_${ci}$tprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib )
end do
else if( right .and. notran ) then
kf = ((k-1)/mb)*mb+1
do i = kf, 1, -mb
ib = min( mb, k-i+1 )
nb = min( n-l+i+ib-1, n )
if( i>=l ) then
lb = 0_${ik}$
else
lb = nb-n+l-i+1
end if
call stdlib${ii}$_${ci}$tprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), &
ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m )
end do
end if
return
end subroutine stdlib${ii}$_${ci}$tpmlqt
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgeqlf( m, n, a, lda, tau, work, lwork, info )
!! SGEQLF computes a QL factorization of a real M-by-N matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ki, kk, ldwork, lwkopt, mu, nb, nbmin, nu, &
nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info==0_${ik}$ ) then
k = min( m, n )
if( k==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEQLF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( k==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 1_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'SGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SGEQLF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially.
! the last kk columns are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
do i = k - kk + ki + 1, k - kk + 1, -nb
ib = min( k-i+1, nb )
! compute the ql factorization of the current block
! a(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
call stdlib${ii}$_sgeql2( m-k+i+ib-1, ib, a( 1_${ik}$, n-k+i ), lda, tau( i ),work, iinfo )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_slarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h**t to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_slarfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, &
n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
end do
mu = m - k + i + nb - 1_${ik}$
nu = n - k + i + nb - 1_${ik}$
else
mu = m
nu = n
end if
! use unblocked code to factor the last or only block
if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_sgeql2( mu, nu, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_sgeqlf
pure module subroutine stdlib${ii}$_dgeqlf( m, n, a, lda, tau, work, lwork, info )
!! DGEQLF computes a QL factorization of a real M-by-N matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ki, kk, ldwork, lwkopt, mu, nb, nbmin, nu, &
nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info==0_${ik}$ ) then
k = min( m, n )
if( k==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEQLF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( k==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 1_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'DGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGEQLF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially.
! the last kk columns are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
do i = k - kk + ki + 1, k - kk + 1, -nb
ib = min( k-i+1, nb )
! compute the ql factorization of the current block
! a(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
call stdlib${ii}$_dgeql2( m-k+i+ib-1, ib, a( 1_${ik}$, n-k+i ), lda, tau( i ),work, iinfo )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_dlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h**t to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_dlarfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, &
n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
end do
mu = m - k + i + nb - 1_${ik}$
nu = n - k + i + nb - 1_${ik}$
else
mu = m
nu = n
end if
! use unblocked code to factor the last or only block
if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_dgeql2( mu, nu, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_dgeqlf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$geqlf( m, n, a, lda, tau, work, lwork, info )
!! DGEQLF: computes a QL factorization of a real M-by-N matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ki, kk, ldwork, lwkopt, mu, nb, nbmin, nu, &
nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info==0_${ik}$ ) then
k = min( m, n )
if( k==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEQLF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( k==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 1_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'DGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGEQLF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially.
! the last kk columns are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
do i = k - kk + ki + 1, k - kk + 1, -nb
ib = min( k-i+1, nb )
! compute the ql factorization of the current block
! a(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
call stdlib${ii}$_${ri}$geql2( m-k+i+ib-1, ib, a( 1_${ik}$, n-k+i ), lda, tau( i ),work, iinfo )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_${ri}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h**t to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, &
n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
end do
mu = m - k + i + nb - 1_${ik}$
nu = n - k + i + nb - 1_${ik}$
else
mu = m
nu = n
end if
! use unblocked code to factor the last or only block
if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_${ri}$geql2( mu, nu, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ri}$geqlf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgeqlf( m, n, a, lda, tau, work, lwork, info )
!! CGEQLF computes a QL factorization of a complex M-by-N matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ki, kk, ldwork, lwkopt, mu, nb, nbmin, nu, &
nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info==0_${ik}$ ) then
k = min( m, n )
if( k==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEQLF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( k==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 1_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'CGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CGEQLF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially.
! the last kk columns are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
do i = k - kk + ki + 1, k - kk + 1, -nb
ib = min( k-i+1, nb )
! compute the ql factorization of the current block
! a(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
call stdlib${ii}$_cgeql2( m-k+i+ib-1, ib, a( 1_${ik}$, n-k+i ), lda, tau( i ),work, iinfo )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_clarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h**h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_clarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-&
k+i+ib-1, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), &
ldwork )
end if
end do
mu = m - k + i + nb - 1_${ik}$
nu = n - k + i + nb - 1_${ik}$
else
mu = m
nu = n
end if
! use unblocked code to factor the last or only block
if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_cgeql2( mu, nu, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_cgeqlf
pure module subroutine stdlib${ii}$_zgeqlf( m, n, a, lda, tau, work, lwork, info )
!! ZGEQLF computes a QL factorization of a complex M-by-N matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ki, kk, ldwork, lwkopt, mu, nb, nbmin, nu, &
nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info==0_${ik}$ ) then
k = min( m, n )
if( k==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEQLF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( k==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 1_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGEQLF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially.
! the last kk columns are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
do i = k - kk + ki + 1, k - kk + 1, -nb
ib = min( k-i+1, nb )
! compute the ql factorization of the current block
! a(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
call stdlib${ii}$_zgeql2( m-k+i+ib-1, ib, a( 1_${ik}$, n-k+i ), lda, tau( i ),work, iinfo )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_zlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h**h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_zlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-&
k+i+ib-1, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), &
ldwork )
end if
end do
mu = m - k + i + nb - 1_${ik}$
nu = n - k + i + nb - 1_${ik}$
else
mu = m
nu = n
end if
! use unblocked code to factor the last or only block
if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_zgeql2( mu, nu, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_zgeqlf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$geqlf( m, n, a, lda, tau, work, lwork, info )
!! ZGEQLF: computes a QL factorization of a complex M-by-N matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, ib, iinfo, iws, k, ki, kk, ldwork, lwkopt, mu, nb, nbmin, nu, &
nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info==0_${ik}$ ) then
k = min( m, n )
if( k==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -7_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEQLF', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( k==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 1_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZGEQLF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGEQLF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code initially.
! the last kk columns are handled by the block method.
ki = ( ( k-nx-1 ) / nb )*nb
kk = min( k, ki+nb )
do i = k - kk + ki + 1, k - kk + 1, -nb
ib = min( k-i+1, nb )
! compute the ql factorization of the current block
! a(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
call stdlib${ii}$_${ci}$geql2( m-k+i+ib-1, ib, a( 1_${ik}$, n-k+i ), lda, tau( i ),work, iinfo )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_${ci}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h**h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-&
k+i+ib-1, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), &
ldwork )
end if
end do
mu = m - k + i + nb - 1_${ik}$
nu = n - k + i + nb - 1_${ik}$
else
mu = m
nu = n
end if
! use unblocked code to factor the last or only block
if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_${ci}$geql2( mu, nu, a, lda, tau, work, iinfo )
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ci}$geqlf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgeql2( m, n, a, lda, tau, work, info )
!! SGEQL2 computes a QL factorization of a real m by n matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
real(sp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEQL2', -info )
return
end if
k = min( m, n )
do i = k, 1, -1
! generate elementary reflector h(i) to annihilate
! a(1:m-k+i-1,n-k+i)
call stdlib${ii}$_slarfg( m-k+i, a( m-k+i, n-k+i ), a( 1_${ik}$, n-k+i ), 1_${ik}$,tau( i ) )
! apply h(i) to a(1:m-k+i,1:n-k+i-1) from the left
aii = a( m-k+i, n-k+i )
a( m-k+i, n-k+i ) = one
call stdlib${ii}$_slarf( 'LEFT', m-k+i, n-k+i-1, a( 1_${ik}$, n-k+i ), 1_${ik}$, tau( i ),a, lda, work )
a( m-k+i, n-k+i ) = aii
end do
return
end subroutine stdlib${ii}$_sgeql2
pure module subroutine stdlib${ii}$_dgeql2( m, n, a, lda, tau, work, info )
!! DGEQL2 computes a QL factorization of a real m by n matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
real(dp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEQL2', -info )
return
end if
k = min( m, n )
do i = k, 1, -1
! generate elementary reflector h(i) to annihilate
! a(1:m-k+i-1,n-k+i)
call stdlib${ii}$_dlarfg( m-k+i, a( m-k+i, n-k+i ), a( 1_${ik}$, n-k+i ), 1_${ik}$,tau( i ) )
! apply h(i) to a(1:m-k+i,1:n-k+i-1) from the left
aii = a( m-k+i, n-k+i )
a( m-k+i, n-k+i ) = one
call stdlib${ii}$_dlarf( 'LEFT', m-k+i, n-k+i-1, a( 1_${ik}$, n-k+i ), 1_${ik}$, tau( i ),a, lda, work )
a( m-k+i, n-k+i ) = aii
end do
return
end subroutine stdlib${ii}$_dgeql2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$geql2( m, n, a, lda, tau, work, info )
!! DGEQL2: computes a QL factorization of a real m by n matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
real(${rk}$) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEQL2', -info )
return
end if
k = min( m, n )
do i = k, 1, -1
! generate elementary reflector h(i) to annihilate
! a(1:m-k+i-1,n-k+i)
call stdlib${ii}$_${ri}$larfg( m-k+i, a( m-k+i, n-k+i ), a( 1_${ik}$, n-k+i ), 1_${ik}$,tau( i ) )
! apply h(i) to a(1:m-k+i,1:n-k+i-1) from the left
aii = a( m-k+i, n-k+i )
a( m-k+i, n-k+i ) = one
call stdlib${ii}$_${ri}$larf( 'LEFT', m-k+i, n-k+i-1, a( 1_${ik}$, n-k+i ), 1_${ik}$, tau( i ),a, lda, work )
a( m-k+i, n-k+i ) = aii
end do
return
end subroutine stdlib${ii}$_${ri}$geql2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgeql2( m, n, a, lda, tau, work, info )
!! CGEQL2 computes a QL factorization of a complex m by n matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
complex(sp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEQL2', -info )
return
end if
k = min( m, n )
do i = k, 1, -1
! generate elementary reflector h(i) to annihilate
! a(1:m-k+i-1,n-k+i)
alpha = a( m-k+i, n-k+i )
call stdlib${ii}$_clarfg( m-k+i, alpha, a( 1_${ik}$, n-k+i ), 1_${ik}$, tau( i ) )
! apply h(i)**h to a(1:m-k+i,1:n-k+i-1) from the left
a( m-k+i, n-k+i ) = cone
call stdlib${ii}$_clarf( 'LEFT', m-k+i, n-k+i-1, a( 1_${ik}$, n-k+i ), 1_${ik}$,conjg( tau( i ) ), a, &
lda, work )
a( m-k+i, n-k+i ) = alpha
end do
return
end subroutine stdlib${ii}$_cgeql2
pure module subroutine stdlib${ii}$_zgeql2( m, n, a, lda, tau, work, info )
!! ZGEQL2 computes a QL factorization of a complex m by n matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
complex(dp) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEQL2', -info )
return
end if
k = min( m, n )
do i = k, 1, -1
! generate elementary reflector h(i) to annihilate
! a(1:m-k+i-1,n-k+i)
alpha = a( m-k+i, n-k+i )
call stdlib${ii}$_zlarfg( m-k+i, alpha, a( 1_${ik}$, n-k+i ), 1_${ik}$, tau( i ) )
! apply h(i)**h to a(1:m-k+i,1:n-k+i-1) from the left
a( m-k+i, n-k+i ) = cone
call stdlib${ii}$_zlarf( 'LEFT', m-k+i, n-k+i-1, a( 1_${ik}$, n-k+i ), 1_${ik}$,conjg( tau( i ) ), a, &
lda, work )
a( m-k+i, n-k+i ) = alpha
end do
return
end subroutine stdlib${ii}$_zgeql2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$geql2( m, n, a, lda, tau, work, info )
!! ZGEQL2: computes a QL factorization of a complex m by n matrix A:
!! A = Q * L.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, k
complex(${ck}$) :: alpha
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEQL2', -info )
return
end if
k = min( m, n )
do i = k, 1, -1
! generate elementary reflector h(i) to annihilate
! a(1:m-k+i-1,n-k+i)
alpha = a( m-k+i, n-k+i )
call stdlib${ii}$_${ci}$larfg( m-k+i, alpha, a( 1_${ik}$, n-k+i ), 1_${ik}$, tau( i ) )
! apply h(i)**h to a(1:m-k+i,1:n-k+i-1) from the left
a( m-k+i, n-k+i ) = cone
call stdlib${ii}$_${ci}$larf( 'LEFT', m-k+i, n-k+i-1, a( 1_${ik}$, n-k+i ), 1_${ik}$,conjg( tau( i ) ), a, &
lda, work )
a( m-k+i, n-k+i ) = alpha
end do
return
end subroutine stdlib${ii}$_${ci}$geql2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cungql( m, n, k, a, lda, tau, work, lwork, info )
!! CUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
!! which is defined as the last N columns of a product of K elementary
!! reflectors of order M
!! Q = H(k) . . . H(2) H(1)
!! as returned by CGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQL', ' ', m, n, k, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNGQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n<=0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'CUNGQL', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CUNGQL', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the first block.
! the last kk columns are handled by the block method.
kk = min( k, ( ( k-nx+nb-1 ) / nb )*nb )
! set a(m-kk+1:m,1:n-kk) to czero.
do j = 1, n - kk
do i = m - kk + 1, m
a( i, j ) = czero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the first or only block.
call stdlib${ii}$_cung2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = k - kk + 1, k, nb
ib = min( nb, k-i+1 )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_clarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_clarfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-&
1_${ik}$, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
! apply h to rows 1:m-k+i+ib-1 of current block
call stdlib${ii}$_cung2l( m-k+i+ib-1, ib, ib, a( 1_${ik}$, n-k+i ), lda,tau( i ), work, iinfo &
)
! set rows m-k+i+ib:m of current block to czero
do j = n - k + i, n - k + i + ib - 1
do l = m - k + i + ib, m
a( l, j ) = czero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_cungql
pure module subroutine stdlib${ii}$_zungql( m, n, k, a, lda, tau, work, lwork, info )
!! ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
!! which is defined as the last N columns of a product of K elementary
!! reflectors of order M
!! Q = H(k) . . . H(2) H(1)
!! as returned by ZGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQL', ' ', m, n, k, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n<=0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZUNGQL', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZUNGQL', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the first block.
! the last kk columns are handled by the block method.
kk = min( k, ( ( k-nx+nb-1 ) / nb )*nb )
! set a(m-kk+1:m,1:n-kk) to czero.
do j = 1, n - kk
do i = m - kk + 1, m
a( i, j ) = czero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the first or only block.
call stdlib${ii}$_zung2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = k - kk + 1, k, nb
ib = min( nb, k-i+1 )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_zlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_zlarfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-&
1_${ik}$, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
! apply h to rows 1:m-k+i+ib-1 of current block
call stdlib${ii}$_zung2l( m-k+i+ib-1, ib, ib, a( 1_${ik}$, n-k+i ), lda,tau( i ), work, iinfo &
)
! set rows m-k+i+ib:m of current block to czero
do j = n - k + i, n - k + i + ib - 1
do l = m - k + i + ib, m
a( l, j ) = czero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_zungql
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ungql( m, n, k, a, lda, tau, work, lwork, info )
!! ZUNGQL: generates an M-by-N complex matrix Q with orthonormal columns,
!! which is defined as the last N columns of a product of K elementary
!! reflectors of order M
!! Q = H(k) . . . H(2) H(1)
!! as returned by ZGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQL', ' ', m, n, k, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n<=0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZUNGQL', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZUNGQL', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the first block.
! the last kk columns are handled by the block method.
kk = min( k, ( ( k-nx+nb-1 ) / nb )*nb )
! set a(m-kk+1:m,1:n-kk) to czero.
do j = 1, n - kk
do i = m - kk + 1, m
a( i, j ) = czero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the first or only block.
call stdlib${ii}$_${ci}$ung2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = k - kk + 1, k, nb
ib = min( nb, k-i+1 )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_${ci}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_${ci}$larfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-&
1_${ik}$, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
! apply h to rows 1:m-k+i+ib-1 of current block
call stdlib${ii}$_${ci}$ung2l( m-k+i+ib-1, ib, ib, a( 1_${ik}$, n-k+i ), lda,tau( i ), work, iinfo &
)
! set rows m-k+i+ib:m of current block to czero
do j = n - k + i, n - k + i + ib - 1
do l = m - k + i + ib, m
a( l, j ) = czero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ci}$ungql
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! CUNMQL 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*), c(ldc,*)
complex(sp), intent(in) :: tau(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, i1, i2, i3, ib, iinfo, iwt, ldwork, lwkopt, mi, nb, nbmin, ni, nq, &
nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQL', side // trans, m, n,k, -1_${ik}$ ) )
lwkopt = nw*nb + tsize
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNMQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
return
end if
! determine the block size
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CUNMQL', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_cunm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_clarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, &
tau( i ), work( iwt ), ldt )
if( left ) then
! h or h**h is applied to c(1:m-k+i+ib-1,1:n)
mi = m - k + i + ib - 1_${ik}$
else
! h or h**h is applied to c(1:m,1:n-k+i+ib-1)
ni = n - k + i + ib - 1_${ik}$
end if
! apply h or h**h
call stdlib${ii}$_clarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1_${ik}$, i ), &
lda, work( iwt ), ldt, c, ldc,work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cunmql
pure module subroutine stdlib${ii}$_zunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! ZUNMQL 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*), c(ldc,*)
complex(dp), intent(in) :: tau(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, i1, i2, i3, ib, iinfo, iwt, ldwork, lwkopt, mi, nb, nbmin, ni, nq, &
nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQL', side // trans, m, n,k, -1_${ik}$ ) )
lwkopt = nw*nb + tsize
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNMQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZUNMQL', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_zunm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_zlarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, &
tau( i ), work( iwt ), ldt )
if( left ) then
! h or h**h is applied to c(1:m-k+i+ib-1,1:n)
mi = m - k + i + ib - 1_${ik}$
else
! h or h**h is applied to c(1:m,1:n-k+i+ib-1)
ni = n - k + i + ib - 1_${ik}$
end if
! apply h or h**h
call stdlib${ii}$_zlarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1_${ik}$, i ), &
lda, work( iwt ), ldt, c, ldc,work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zunmql
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! ZUNMQL: 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*)
complex(${ck}$), intent(in) :: tau(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, i1, i2, i3, ib, iinfo, iwt, ldwork, lwkopt, mi, nb, nbmin, ni, nq, &
nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQL', side // trans, m, n,k, -1_${ik}$ ) )
lwkopt = nw*nb + tsize
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNMQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZUNMQL', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_${ci}$unm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_${ci}$larft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, &
tau( i ), work( iwt ), ldt )
if( left ) then
! h or h**h is applied to c(1:m-k+i+ib-1,1:n)
mi = m - k + i + ib - 1_${ik}$
else
! h or h**h is applied to c(1:m,1:n-k+i+ib-1)
ni = n - k + i + ib - 1_${ik}$
end if
! apply h or h**h
call stdlib${ii}$_${ci}$larfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1_${ik}$, i ), &
lda, work( iwt ), ldt, c, ldc,work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$unmql
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cung2l( m, n, k, a, lda, tau, work, info )
!! CUNG2L generates an m by n complex matrix Q with orthonormal columns,
!! which is defined as the last n columns of a product of k elementary
!! reflectors of order m
!! Q = H(k) . . . H(2) H(1)
!! as returned by CGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(in) :: tau(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNG2L', -info )
return
end if
! quick return if possible
if( n<=0 )return
! initialise columns 1:n-k to columns of the unit matrix
do j = 1, n - k
do l = 1, m
a( l, j ) = czero
end do
a( m-n+j, j ) = cone
end do
do i = 1, k
ii = n - k + i
! apply h(i) to a(1:m-k+i,1:n-k+i) from the left
a( m-n+ii, ii ) = cone
call stdlib${ii}$_clarf( 'LEFT', m-n+ii, ii-1, a( 1_${ik}$, ii ), 1_${ik}$, tau( i ), a,lda, work )
call stdlib${ii}$_cscal( m-n+ii-1, -tau( i ), a( 1_${ik}$, ii ), 1_${ik}$ )
a( m-n+ii, ii ) = cone - tau( i )
! set a(m-k+i+1:m,n-k+i) to czero
do l = m - n + ii + 1, m
a( l, ii ) = czero
end do
end do
return
end subroutine stdlib${ii}$_cung2l
pure module subroutine stdlib${ii}$_zung2l( m, n, k, a, lda, tau, work, info )
!! ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
!! which is defined as the last n columns of a product of k elementary
!! reflectors of order m
!! Q = H(k) . . . H(2) H(1)
!! as returned by ZGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(in) :: tau(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNG2L', -info )
return
end if
! quick return if possible
if( n<=0 )return
! initialise columns 1:n-k to columns of the unit matrix
do j = 1, n - k
do l = 1, m
a( l, j ) = czero
end do
a( m-n+j, j ) = cone
end do
do i = 1, k
ii = n - k + i
! apply h(i) to a(1:m-k+i,1:n-k+i) from the left
a( m-n+ii, ii ) = cone
call stdlib${ii}$_zlarf( 'LEFT', m-n+ii, ii-1, a( 1_${ik}$, ii ), 1_${ik}$, tau( i ), a,lda, work )
call stdlib${ii}$_zscal( m-n+ii-1, -tau( i ), a( 1_${ik}$, ii ), 1_${ik}$ )
a( m-n+ii, ii ) = cone - tau( i )
! set a(m-k+i+1:m,n-k+i) to czero
do l = m - n + ii + 1, m
a( l, ii ) = czero
end do
end do
return
end subroutine stdlib${ii}$_zung2l
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ung2l( m, n, k, a, lda, tau, work, info )
!! ZUNG2L: generates an m by n complex matrix Q with orthonormal columns,
!! which is defined as the last n columns of a product of k elementary
!! reflectors of order m
!! Q = H(k) . . . H(2) H(1)
!! as returned by ZGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(in) :: tau(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNG2L', -info )
return
end if
! quick return if possible
if( n<=0 )return
! initialise columns 1:n-k to columns of the unit matrix
do j = 1, n - k
do l = 1, m
a( l, j ) = czero
end do
a( m-n+j, j ) = cone
end do
do i = 1, k
ii = n - k + i
! apply h(i) to a(1:m-k+i,1:n-k+i) from the left
a( m-n+ii, ii ) = cone
call stdlib${ii}$_${ci}$larf( 'LEFT', m-n+ii, ii-1, a( 1_${ik}$, ii ), 1_${ik}$, tau( i ), a,lda, work )
call stdlib${ii}$_${ci}$scal( m-n+ii-1, -tau( i ), a( 1_${ik}$, ii ), 1_${ik}$ )
a( m-n+ii, ii ) = cone - tau( i )
! set a(m-k+i+1:m,n-k+i) to czero
do l = m - n + ii + 1, m
a( l, ii ) = czero
end do
end do
return
end subroutine stdlib${ii}$_${ci}$ung2l
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! CUNM2L overwrites the general complex m-by-n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**H* C if SIDE = 'L' and TRANS = 'C', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**H if SIDE = 'R' and TRANS = 'C',
!! where Q is a complex unitary matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq
complex(sp) :: aii, taui
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNM2L', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran .or. .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
if( left ) then
! h(i) or h(i)**h is applied to c(1:m-k+i,1:n)
mi = m - k + i
else
! h(i) or h(i)**h is applied to c(1:m,1:n-k+i)
ni = n - k + i
end if
! apply h(i) or h(i)**h
if( notran ) then
taui = tau( i )
else
taui = conjg( tau( i ) )
end if
aii = a( nq-k+i, i )
a( nq-k+i, i ) = cone
call stdlib${ii}$_clarf( side, mi, ni, a( 1_${ik}$, i ), 1_${ik}$, taui, c, ldc, work )
a( nq-k+i, i ) = aii
end do
return
end subroutine stdlib${ii}$_cunm2l
pure module subroutine stdlib${ii}$_zunm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! ZUNM2L overwrites the general complex m-by-n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**H* C if SIDE = 'L' and TRANS = 'C', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**H if SIDE = 'R' and TRANS = 'C',
!! where Q is a complex unitary matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq
complex(dp) :: aii, taui
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNM2L', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran .or. .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
if( left ) then
! h(i) or h(i)**h is applied to c(1:m-k+i,1:n)
mi = m - k + i
else
! h(i) or h(i)**h is applied to c(1:m,1:n-k+i)
ni = n - k + i
end if
! apply h(i) or h(i)**h
if( notran ) then
taui = tau( i )
else
taui = conjg( tau( i ) )
end if
aii = a( nq-k+i, i )
a( nq-k+i, i ) = cone
call stdlib${ii}$_zlarf( side, mi, ni, a( 1_${ik}$, i ), 1_${ik}$, taui, c, ldc, work )
a( nq-k+i, i ) = aii
end do
return
end subroutine stdlib${ii}$_zunm2l
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! ZUNM2L: overwrites the general complex m-by-n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**H* C if SIDE = 'L' and TRANS = 'C', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**H if SIDE = 'R' and TRANS = 'C',
!! where Q is a complex unitary matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq
complex(${ck}$) :: aii, taui
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNM2L', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran .or. .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
if( left ) then
! h(i) or h(i)**h is applied to c(1:m-k+i,1:n)
mi = m - k + i
else
! h(i) or h(i)**h is applied to c(1:m,1:n-k+i)
ni = n - k + i
end if
! apply h(i) or h(i)**h
if( notran ) then
taui = tau( i )
else
taui = conjg( tau( i ) )
end if
aii = a( nq-k+i, i )
a( nq-k+i, i ) = cone
call stdlib${ii}$_${ci}$larf( side, mi, ni, a( 1_${ik}$, i ), 1_${ik}$, taui, c, ldc, work )
a( nq-k+i, i ) = aii
end do
return
end subroutine stdlib${ii}$_${ci}$unm2l
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sorgql( m, n, k, a, lda, tau, work, lwork, info )
!! SORGQL generates an M-by-N real matrix Q with orthonormal columns,
!! which is defined as the last N columns of a product of K elementary
!! reflectors of order M
!! Q = H(k) . . . H(2) H(1)
!! as returned by SGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQL', ' ', m, n, k, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORGQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n<=0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'SORGQL', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SORGQL', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the first block.
! the last kk columns are handled by the block method.
kk = min( k, ( ( k-nx+nb-1 ) / nb )*nb )
! set a(m-kk+1:m,1:n-kk) to zero.
do j = 1, n - kk
do i = m - kk + 1, m
a( i, j ) = zero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the first or only block.
call stdlib${ii}$_sorg2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = k - kk + 1, k, nb
ib = min( nb, k-i+1 )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_slarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_slarfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-&
1_${ik}$, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
! apply h to rows 1:m-k+i+ib-1 of current block
call stdlib${ii}$_sorg2l( m-k+i+ib-1, ib, ib, a( 1_${ik}$, n-k+i ), lda,tau( i ), work, iinfo &
)
! set rows m-k+i+ib:m of current block to zero
do j = n - k + i, n - k + i + ib - 1
do l = m - k + i + ib, m
a( l, j ) = zero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_sorgql
pure module subroutine stdlib${ii}$_dorgql( m, n, k, a, lda, tau, work, lwork, info )
!! DORGQL generates an M-by-N real matrix Q with orthonormal columns,
!! which is defined as the last N columns of a product of K elementary
!! reflectors of order M
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQL', ' ', m, n, k, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n<=0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'DORGQL', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DORGQL', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the first block.
! the last kk columns are handled by the block method.
kk = min( k, ( ( k-nx+nb-1 ) / nb )*nb )
! set a(m-kk+1:m,1:n-kk) to zero.
do j = 1, n - kk
do i = m - kk + 1, m
a( i, j ) = zero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the first or only block.
call stdlib${ii}$_dorg2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = k - kk + 1, k, nb
ib = min( nb, k-i+1 )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_dlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_dlarfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-&
1_${ik}$, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
! apply h to rows 1:m-k+i+ib-1 of current block
call stdlib${ii}$_dorg2l( m-k+i+ib-1, ib, ib, a( 1_${ik}$, n-k+i ), lda,tau( i ), work, iinfo &
)
! set rows m-k+i+ib:m of current block to zero
do j = n - k + i, n - k + i + ib - 1
do l = m - k + i + ib, m
a( l, j ) = zero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_dorgql
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$orgql( m, n, k, a, lda, tau, work, lwork, info )
!! DORGQL: generates an M-by-N real matrix Q with orthonormal columns,
!! which is defined as the last N columns of a product of K elementary
!! reflectors of order M
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, lwork, m, n
! 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, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQL', ' ', m, n, k, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -8_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n<=0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
nx = 0_${ik}$
iws = n
if( nb>1_${ik}$ .and. nb<k ) then
! determine when to cross over from blocked to unblocked code.
nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( 3_${ik}$, 'DORGQL', ' ', m, n, k, -1_${ik}$ ) )
if( nx<k ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: reduce nb and
! determine the minimum value of nb.
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DORGQL', ' ', m, n, k, -1_${ik}$ ) )
end if
end if
end if
if( nb>=nbmin .and. nb<k .and. nx<k ) then
! use blocked code after the first block.
! the last kk columns are handled by the block method.
kk = min( k, ( ( k-nx+nb-1 ) / nb )*nb )
! set a(m-kk+1:m,1:n-kk) to zero.
do j = 1, n - kk
do i = m - kk + 1, m
a( i, j ) = zero
end do
end do
else
kk = 0_${ik}$
end if
! use unblocked code for the first or only block.
call stdlib${ii}$_${ri}$org2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo )
if( kk>0_${ik}$ ) then
! use blocked code
do i = k - kk + 1, k, nb
ib = min( nb, k-i+1 )
if( n-k+i>1_${ik}$ ) then
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_${ri}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), &
lda, tau( i ), work, ldwork )
! apply h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left
call stdlib${ii}$_${ri}$larfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-&
1_${ik}$, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork )
end if
! apply h to rows 1:m-k+i+ib-1 of current block
call stdlib${ii}$_${ri}$org2l( m-k+i+ib-1, ib, ib, a( 1_${ik}$, n-k+i ), lda,tau( i ), work, iinfo &
)
! set rows m-k+i+ib:m of current block to zero
do j = n - k + i, n - k + i + ib - 1
do l = m - k + i + ib, m
a( l, j ) = zero
end do
end do
end do
end if
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ri}$orgql
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! SORMQL 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*), c(ldc,*)
real(sp), intent(in) :: tau(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, i1, i2, i3, ib, iinfo, iwt, ldwork, lwkopt, mi, nb, nbmin, ni, nq, &
nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQL', side // trans, m, n,k, -1_${ik}$ ) )
lwkopt = nw*nb + tsize
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORMQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SORMQL', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_sorm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_slarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, &
tau( i ), work( iwt ), ldt )
if( left ) then
! h or h**t is applied to c(1:m-k+i+ib-1,1:n)
mi = m - k + i + ib - 1_${ik}$
else
! h or h**t is applied to c(1:m,1:n-k+i+ib-1)
ni = n - k + i + ib - 1_${ik}$
end if
! apply h or h**t
call stdlib${ii}$_slarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1_${ik}$, i ), &
lda, work( iwt ), ldt, c, ldc,work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sormql
pure module subroutine stdlib${ii}$_dormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! DORMQL 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*), c(ldc,*)
real(dp), intent(in) :: tau(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, i1, i2, i3, ib, iinfo, iwt, ldwork, lwkopt, mi, nb, nbmin, ni, nq, &
nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQL', side // trans, m, n,k, -1_${ik}$ ) )
lwkopt = nw*nb + tsize
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORMQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DORMQL', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_dorm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_dlarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, &
tau( i ), work( iwt ), ldt )
if( left ) then
! h or h**t is applied to c(1:m-k+i+ib-1,1:n)
mi = m - k + i + ib - 1_${ik}$
else
! h or h**t is applied to c(1:m,1:n-k+i+ib-1)
ni = n - k + i + ib - 1_${ik}$
end if
! apply h or h**t
call stdlib${ii}$_dlarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1_${ik}$, i ), &
lda, work( iwt ), ldt, c, ldc,work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dormql
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info )
!! DORMQL: 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 defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*)
real(${rk}$), intent(in) :: tau(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldt = nbmax+1
integer(${ik}$), parameter :: tsize = ldt*nbmax
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, i1, i2, i3, ib, iinfo, iwt, ldwork, lwkopt, mi, nb, nbmin, ni, nq, &
nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
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.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQL', side // trans, m, n,k, -1_${ik}$ ) )
lwkopt = nw*nb + tsize
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORMQL', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
return
end if
nbmin = 2_${ik}$
ldwork = nw
if( nb>1_${ik}$ .and. nb<k ) then
if( lwork<lwkopt ) then
nb = (lwork-tsize) / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DORMQL', side // trans, m, n, k,-1_${ik}$ ) )
end if
end if
if( nb<nbmin .or. nb>=k ) then
! use unblocked code
call stdlib${ii}$_${ri}$orm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo )
else
! use blocked code
iwt = 1_${ik}$ + nw*nb
if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then
i1 = 1_${ik}$
i2 = k
i3 = nb
else
i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$
i2 = 1_${ik}$
i3 = -nb
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
ib = min( nb, k-i+1 )
! form the triangular factor of the block reflector
! h = h(i+ib-1) . . . h(i+1) h(i)
call stdlib${ii}$_${ri}$larft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, &
tau( i ), work( iwt ), ldt )
if( left ) then
! h or h**t is applied to c(1:m-k+i+ib-1,1:n)
mi = m - k + i + ib - 1_${ik}$
else
! h or h**t is applied to c(1:m,1:n-k+i+ib-1)
ni = n - k + i + ib - 1_${ik}$
end if
! apply h or h**t
call stdlib${ii}$_${ri}$larfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1_${ik}$, i ), &
lda, work( iwt ), ldt, c, ldc,work, ldwork )
end do
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$ormql
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sorg2l( m, n, k, a, lda, tau, work, info )
!! SORG2L generates an m by n real matrix Q with orthonormal columns,
!! which is defined as the last n columns of a product of k elementary
!! reflectors of order m
!! Q = H(k) . . . H(2) H(1)
!! as returned by SGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(in) :: tau(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORG2L', -info )
return
end if
! quick return if possible
if( n<=0 )return
! initialise columns 1:n-k to columns of the unit matrix
do j = 1, n - k
do l = 1, m
a( l, j ) = zero
end do
a( m-n+j, j ) = one
end do
do i = 1, k
ii = n - k + i
! apply h(i) to a(1:m-k+i,1:n-k+i) from the left
a( m-n+ii, ii ) = one
call stdlib${ii}$_slarf( 'LEFT', m-n+ii, ii-1, a( 1_${ik}$, ii ), 1_${ik}$, tau( i ), a,lda, work )
call stdlib${ii}$_sscal( m-n+ii-1, -tau( i ), a( 1_${ik}$, ii ), 1_${ik}$ )
a( m-n+ii, ii ) = one - tau( i )
! set a(m-k+i+1:m,n-k+i) to zero
do l = m - n + ii + 1, m
a( l, ii ) = zero
end do
end do
return
end subroutine stdlib${ii}$_sorg2l
pure module subroutine stdlib${ii}$_dorg2l( m, n, k, a, lda, tau, work, info )
!! DORG2L generates an m by n real matrix Q with orthonormal columns,
!! which is defined as the last n columns of a product of k elementary
!! reflectors of order m
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(in) :: tau(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORG2L', -info )
return
end if
! quick return if possible
if( n<=0 )return
! initialise columns 1:n-k to columns of the unit matrix
do j = 1, n - k
do l = 1, m
a( l, j ) = zero
end do
a( m-n+j, j ) = one
end do
do i = 1, k
ii = n - k + i
! apply h(i) to a(1:m-k+i,1:n-k+i) from the left
a( m-n+ii, ii ) = one
call stdlib${ii}$_dlarf( 'LEFT', m-n+ii, ii-1, a( 1_${ik}$, ii ), 1_${ik}$, tau( i ), a,lda, work )
call stdlib${ii}$_dscal( m-n+ii-1, -tau( i ), a( 1_${ik}$, ii ), 1_${ik}$ )
a( m-n+ii, ii ) = one - tau( i )
! set a(m-k+i+1:m,n-k+i) to zero
do l = m - n + ii + 1, m
a( l, ii ) = zero
end do
end do
return
end subroutine stdlib${ii}$_dorg2l
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$org2l( m, n, k, a, lda, tau, work, info )
!! DORG2L: generates an m by n real matrix Q with orthonormal columns,
!! which is defined as the last n columns of a product of k elementary
!! reflectors of order m
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGEQLF.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(in) :: tau(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, j, l
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ .or. n>m ) then
info = -2_${ik}$
else if( k<0_${ik}$ .or. k>n ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORG2L', -info )
return
end if
! quick return if possible
if( n<=0 )return
! initialise columns 1:n-k to columns of the unit matrix
do j = 1, n - k
do l = 1, m
a( l, j ) = zero
end do
a( m-n+j, j ) = one
end do
do i = 1, k
ii = n - k + i
! apply h(i) to a(1:m-k+i,1:n-k+i) from the left
a( m-n+ii, ii ) = one
call stdlib${ii}$_${ri}$larf( 'LEFT', m-n+ii, ii-1, a( 1_${ik}$, ii ), 1_${ik}$, tau( i ), a,lda, work )
call stdlib${ii}$_${ri}$scal( m-n+ii-1, -tau( i ), a( 1_${ik}$, ii ), 1_${ik}$ )
a( m-n+ii, ii ) = one - tau( i )
! set a(m-k+i+1:m,n-k+i) to zero
do l = m - n + ii + 1, m
a( l, ii ) = zero
end do
end do
return
end subroutine stdlib${ii}$_${ri}$org2l
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sorm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! SORM2L overwrites the general real m by n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**T * C if SIDE = 'L' and TRANS = 'T', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**T if SIDE = 'R' and TRANS = 'T',
!! where Q is a real orthogonal matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq
real(sp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORM2L', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran ) .or. ( .not.left .and. .not.notran ) )then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
if( left ) then
! h(i) is applied to c(1:m-k+i,1:n)
mi = m - k + i
else
! h(i) is applied to c(1:m,1:n-k+i)
ni = n - k + i
end if
! apply h(i)
aii = a( nq-k+i, i )
a( nq-k+i, i ) = one
call stdlib${ii}$_slarf( side, mi, ni, a( 1_${ik}$, i ), 1_${ik}$, tau( i ), c, ldc,work )
a( nq-k+i, i ) = aii
end do
return
end subroutine stdlib${ii}$_sorm2l
pure module subroutine stdlib${ii}$_dorm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! DORM2L overwrites the general real m by n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**T * C if SIDE = 'L' and TRANS = 'T', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**T if SIDE = 'R' and TRANS = 'T',
!! where Q is a real orthogonal matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq
real(dp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORM2L', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran ) .or. ( .not.left .and. .not.notran ) )then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
if( left ) then
! h(i) is applied to c(1:m-k+i,1:n)
mi = m - k + i
else
! h(i) is applied to c(1:m,1:n-k+i)
ni = n - k + i
end if
! apply h(i)
aii = a( nq-k+i, i )
a( nq-k+i, i ) = one
call stdlib${ii}$_dlarf( side, mi, ni, a( 1_${ik}$, i ), 1_${ik}$, tau( i ), c, ldc,work )
a( nq-k+i, i ) = aii
end do
return
end subroutine stdlib${ii}$_dorm2l
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$orm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info )
!! DORM2L: overwrites the general real m by n matrix C with
!! Q * C if SIDE = 'L' and TRANS = 'N', or
!! Q**T * C if SIDE = 'L' and TRANS = 'T', or
!! C * Q if SIDE = 'R' and TRANS = 'N', or
!! C * Q**T if SIDE = 'R' and TRANS = 'T',
!! where Q is a real orthogonal matrix defined as the product of k
!! elementary reflectors
!! Q = H(k) . . . H(2) H(1)
!! as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n
!! if SIDE = 'R'.
! -- 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(out) :: info
integer(${ik}$), intent(in) :: k, lda, ldc, m, n
! 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, notran
integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq
real(${rk}$) :: aii
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
! nq is the order of q
if( left ) then
nq = m
else
nq = n
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.notran .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( k<0_${ik}$ .or. k>nq ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORM2L', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 .or. k==0 )return
if( ( left .and. notran ) .or. ( .not.left .and. .not.notran ) )then
i1 = 1_${ik}$
i2 = k
i3 = 1_${ik}$
else
i1 = k
i2 = 1_${ik}$
i3 = -1_${ik}$
end if
if( left ) then
ni = n
else
mi = m
end if
do i = i1, i2, i3
if( left ) then
! h(i) is applied to c(1:m-k+i,1:n)
mi = m - k + i
else
! h(i) is applied to c(1:m,1:n-k+i)
ni = n - k + i
end if
! apply h(i)
aii = a( nq-k+i, i )
a( nq-k+i, i ) = one
call stdlib${ii}$_${ri}$larf( side, mi, ni, a( 1_${ik}$, i ), 1_${ik}$, tau( i ), c, ldc,work )
a( nq-k+i, i ) = aii
end do
return
end subroutine stdlib${ii}$_${ri}$orm2l
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, 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) :: m, n, n1, n2, ldq, ldc, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(sp), intent(in) :: q(ldq,*)
complex(sp), intent(inout) :: c(ldc,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, ldwork, len, lwkopt, nb, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q;
! nw is the minimum dimension of work.
if( left ) then
nq = m
else
nq = n
end if
nw = nq
if( n1==0_${ik}$ .or. n2==0_${ik}$ ) nw = 1_${ik}$
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( n1<0_${ik}$ .or. n1+n2/=nq ) then
info = -5_${ik}$
else if( n2<0_${ik}$ ) then
info = -6_${ik}$
else if( ldq<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = m*n
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNM22', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! degenerate cases (n1 = 0 or n2 = 0) are handled using stdlib${ii}$_ctrmm.
if( n1==0_${ik}$ ) then
call stdlib${ii}$_ctrmm( side, 'UPPER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc )
work( 1_${ik}$ ) = cone
return
else if( n2==0_${ik}$ ) then
call stdlib${ii}$_ctrmm( side, 'LOWER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc )
work( 1_${ik}$ ) = cone
return
end if
! compute the largest chunk size available from the workspace.
nb = max( 1_${ik}$, min( lwork, lwkopt ) / nq )
if( left ) then
if( notran ) then
do i = 1, n, nb
len = min( nb, n-i+1 )
ldwork = m
! multiply bottom part of c by q12.
call stdlib${ii}$_clacpy( 'ALL', n1, len, c( n2+1, i ), ldc, work,ldwork )
call stdlib${ii}$_ctrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',n1, len, cone, &
q( 1_${ik}$, n2+1 ), ldq, work,ldwork )
! multiply top part of c by q11.
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,cone, q, ldq, &
c( 1_${ik}$, i ), ldc, cone, work,ldwork )
! multiply top part of c by q21.
call stdlib${ii}$_clacpy( 'ALL', n2, len, c( 1_${ik}$, i ), ldc,work( n1+1 ), ldwork )
call stdlib${ii}$_ctrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',n2, len, cone, &
q( n1+1, 1_${ik}$ ), ldq,work( n1+1 ), ldwork )
! multiply bottom part of c by q22.
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,cone, q( n1+1, &
n2+1 ), ldq, c( n2+1, i ), ldc,cone, work( n1+1 ), ldwork )
! copy everything back.
call stdlib${ii}$_clacpy( 'ALL', m, len, work, ldwork, c( 1_${ik}$, i ),ldc )
end do
else
do i = 1, n, nb
len = min( nb, n-i+1 )
ldwork = m
! multiply bottom part of c by q21**h.
call stdlib${ii}$_clacpy( 'ALL', n2, len, c( n1+1, i ), ldc, work,ldwork )
call stdlib${ii}$_ctrmm( 'LEFT', 'UPPER', 'CONJUGATE', 'NON-UNIT',n2, len, cone, q( &
n1+1, 1_${ik}$ ), ldq, work,ldwork )
! multiply top part of c by q11**h.
call stdlib${ii}$_cgemm( 'CONJUGATE', 'NO TRANSPOSE', n2, len, n1,cone, q, ldq, c( &
1_${ik}$, i ), ldc, cone, work,ldwork )
! multiply top part of c by q12**h.
call stdlib${ii}$_clacpy( 'ALL', n1, len, c( 1_${ik}$, i ), ldc,work( n2+1 ), ldwork )
call stdlib${ii}$_ctrmm( 'LEFT', 'LOWER', 'CONJUGATE', 'NON-UNIT',n1, len, cone, q( &
1_${ik}$, n2+1 ), ldq,work( n2+1 ), ldwork )
! multiply bottom part of c by q22**h.
call stdlib${ii}$_cgemm( 'CONJUGATE', 'NO TRANSPOSE', n1, len, n2,cone, q( n1+1, n2+&
1_${ik}$ ), ldq, c( n1+1, i ), ldc,cone, work( n2+1 ), ldwork )
! copy everything back.
call stdlib${ii}$_clacpy( 'ALL', m, len, work, ldwork, c( 1_${ik}$, i ),ldc )
end do
end if
else
if( notran ) then
do i = 1, m, nb
len = min( nb, m-i+1 )
ldwork = len
! multiply right part of c by q21.
call stdlib${ii}$_clacpy( 'ALL', len, n2, c( i, n1+1 ), ldc, work,ldwork )
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',len, n2, cone,&
q( n1+1, 1_${ik}$ ), ldq, work,ldwork )
! multiply left part of c by q11.
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n2, n1,cone, c( i, 1_${ik}$ )&
, ldc, q, ldq, cone, work,ldwork )
! multiply left part of c by q12.
call stdlib${ii}$_clacpy( 'ALL', len, n1, c( i, 1_${ik}$ ), ldc,work( 1_${ik}$ + n2*ldwork ), &
ldwork )
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',len, n1, cone,&
q( 1_${ik}$, n2+1 ), ldq,work( 1_${ik}$ + n2*ldwork ), ldwork )
! multiply right part of c by q22.
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n1, n2,cone, c( i, n1+&
1_${ik}$ ), ldc, q( n1+1, n2+1 ), ldq,cone, work( 1_${ik}$ + n2*ldwork ), ldwork )
! copy everything back.
call stdlib${ii}$_clacpy( 'ALL', len, n, work, ldwork, c( i, 1_${ik}$ ),ldc )
end do
else
do i = 1, m, nb
len = min( nb, m-i+1 )
ldwork = len
! multiply right part of c by q12**h.
call stdlib${ii}$_clacpy( 'ALL', len, n1, c( i, n2+1 ), ldc, work,ldwork )
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE', 'NON-UNIT',len, n1, cone, q(&
1_${ik}$, n2+1 ), ldq, work,ldwork )
! multiply left part of c by q11**h.
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE', len, n1, n2,cone, c( i, 1_${ik}$ ), &
ldc, q, ldq, cone, work,ldwork )
! multiply left part of c by q21**h.
call stdlib${ii}$_clacpy( 'ALL', len, n2, c( i, 1_${ik}$ ), ldc,work( 1_${ik}$ + n1*ldwork ), &
ldwork )
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE', 'NON-UNIT',len, n2, cone, q(&
n1+1, 1_${ik}$ ), ldq,work( 1_${ik}$ + n1*ldwork ), ldwork )
! multiply right part of c by q22**h.
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE', len, n2, n1,cone, c( i, n2+1 )&
, ldc, q( n1+1, n2+1 ), ldq,cone, work( 1_${ik}$ + n1*ldwork ), ldwork )
! copy everything back.
call stdlib${ii}$_clacpy( 'ALL', len, n, work, ldwork, c( i, 1_${ik}$ ),ldc )
end do
end if
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
return
end subroutine stdlib${ii}$_cunm22
pure module subroutine stdlib${ii}$_zunm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, 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) :: m, n, n1, n2, ldq, ldc, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(dp), intent(in) :: q(ldq,*)
complex(dp), intent(inout) :: c(ldc,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, ldwork, len, lwkopt, nb, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q;
! nw is the minimum dimension of work.
if( left ) then
nq = m
else
nq = n
end if
nw = nq
if( n1==0_${ik}$ .or. n2==0_${ik}$ ) nw = 1_${ik}$
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( n1<0_${ik}$ .or. n1+n2/=nq ) then
info = -5_${ik}$
else if( n2<0_${ik}$ ) then
info = -6_${ik}$
else if( ldq<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = m*n
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNM22', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! degenerate cases (n1 = 0 or n2 = 0) are handled using stdlib${ii}$_ztrmm.
if( n1==0_${ik}$ ) then
call stdlib${ii}$_ztrmm( side, 'UPPER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc )
work( 1_${ik}$ ) = cone
return
else if( n2==0_${ik}$ ) then
call stdlib${ii}$_ztrmm( side, 'LOWER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc )
work( 1_${ik}$ ) = cone
return
end if
! compute the largest chunk size available from the workspace.
nb = max( 1_${ik}$, min( lwork, lwkopt ) / nq )
if( left ) then
if( notran ) then
do i = 1, n, nb
len = min( nb, n-i+1 )
ldwork = m
! multiply bottom part of c by q12.
call stdlib${ii}$_zlacpy( 'ALL', n1, len, c( n2+1, i ), ldc, work,ldwork )
call stdlib${ii}$_ztrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',n1, len, cone, &
q( 1_${ik}$, n2+1 ), ldq, work,ldwork )
! multiply top part of c by q11.
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,cone, q, ldq, &
c( 1_${ik}$, i ), ldc, cone, work,ldwork )
! multiply top part of c by q21.
call stdlib${ii}$_zlacpy( 'ALL', n2, len, c( 1_${ik}$, i ), ldc,work( n1+1 ), ldwork )
call stdlib${ii}$_ztrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',n2, len, cone, &
q( n1+1, 1_${ik}$ ), ldq,work( n1+1 ), ldwork )
! multiply bottom part of c by q22.
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,cone, q( n1+1, &
n2+1 ), ldq, c( n2+1, i ), ldc,cone, work( n1+1 ), ldwork )
! copy everything back.
call stdlib${ii}$_zlacpy( 'ALL', m, len, work, ldwork, c( 1_${ik}$, i ),ldc )
end do
else
do i = 1, n, nb
len = min( nb, n-i+1 )
ldwork = m
! multiply bottom part of c by q21**h.
call stdlib${ii}$_zlacpy( 'ALL', n2, len, c( n1+1, i ), ldc, work,ldwork )
call stdlib${ii}$_ztrmm( 'LEFT', 'UPPER', 'CONJUGATE', 'NON-UNIT',n2, len, cone, q( &
n1+1, 1_${ik}$ ), ldq, work,ldwork )
! multiply top part of c by q11**h.
call stdlib${ii}$_zgemm( 'CONJUGATE', 'NO TRANSPOSE', n2, len, n1,cone, q, ldq, c( &
1_${ik}$, i ), ldc, cone, work,ldwork )
! multiply top part of c by q12**h.
call stdlib${ii}$_zlacpy( 'ALL', n1, len, c( 1_${ik}$, i ), ldc,work( n2+1 ), ldwork )
call stdlib${ii}$_ztrmm( 'LEFT', 'LOWER', 'CONJUGATE', 'NON-UNIT',n1, len, cone, q( &
1_${ik}$, n2+1 ), ldq,work( n2+1 ), ldwork )
! multiply bottom part of c by q22**h.
call stdlib${ii}$_zgemm( 'CONJUGATE', 'NO TRANSPOSE', n1, len, n2,cone, q( n1+1, n2+&
1_${ik}$ ), ldq, c( n1+1, i ), ldc,cone, work( n2+1 ), ldwork )
! copy everything back.
call stdlib${ii}$_zlacpy( 'ALL', m, len, work, ldwork, c( 1_${ik}$, i ),ldc )
end do
end if
else
if( notran ) then
do i = 1, m, nb
len = min( nb, m-i+1 )
ldwork = len
! multiply right part of c by q21.
call stdlib${ii}$_zlacpy( 'ALL', len, n2, c( i, n1+1 ), ldc, work,ldwork )
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',len, n2, cone,&
q( n1+1, 1_${ik}$ ), ldq, work,ldwork )
! multiply left part of c by q11.
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n2, n1,cone, c( i, 1_${ik}$ )&
, ldc, q, ldq, cone, work,ldwork )
! multiply left part of c by q12.
call stdlib${ii}$_zlacpy( 'ALL', len, n1, c( i, 1_${ik}$ ), ldc,work( 1_${ik}$ + n2*ldwork ), &
ldwork )
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',len, n1, cone,&
q( 1_${ik}$, n2+1 ), ldq,work( 1_${ik}$ + n2*ldwork ), ldwork )
! multiply right part of c by q22.
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n1, n2,cone, c( i, n1+&
1_${ik}$ ), ldc, q( n1+1, n2+1 ), ldq,cone, work( 1_${ik}$ + n2*ldwork ), ldwork )
! copy everything back.
call stdlib${ii}$_zlacpy( 'ALL', len, n, work, ldwork, c( i, 1_${ik}$ ),ldc )
end do
else
do i = 1, m, nb
len = min( nb, m-i+1 )
ldwork = len
! multiply right part of c by q12**h.
call stdlib${ii}$_zlacpy( 'ALL', len, n1, c( i, n2+1 ), ldc, work,ldwork )
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE', 'NON-UNIT',len, n1, cone, q(&
1_${ik}$, n2+1 ), ldq, work,ldwork )
! multiply left part of c by q11**h.
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE', len, n1, n2,cone, c( i, 1_${ik}$ ), &
ldc, q, ldq, cone, work,ldwork )
! multiply left part of c by q21**h.
call stdlib${ii}$_zlacpy( 'ALL', len, n2, c( i, 1_${ik}$ ), ldc,work( 1_${ik}$ + n1*ldwork ), &
ldwork )
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE', 'NON-UNIT',len, n2, cone, q(&
n1+1, 1_${ik}$ ), ldq,work( 1_${ik}$ + n1*ldwork ), ldwork )
! multiply right part of c by q22**h.
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE', len, n2, n1,cone, c( i, n2+1 )&
, ldc, q( n1+1, n2+1 ), ldq,cone, work( 1_${ik}$ + n1*ldwork ), ldwork )
! copy everything back.
call stdlib${ii}$_zlacpy( 'ALL', len, n, work, ldwork, c( i, 1_${ik}$ ),ldc )
end do
end if
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp)
return
end subroutine stdlib${ii}$_zunm22
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, 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) :: m, n, n1, n2, ldq, ldc, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(${ck}$), intent(in) :: q(ldq,*)
complex(${ck}$), intent(inout) :: c(ldc,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, notran
integer(${ik}$) :: i, ldwork, len, lwkopt, nb, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
notran = stdlib_lsame( trans, 'N' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q;
! nw is the minimum dimension of work.
if( left ) then
nq = m
else
nq = n
end if
nw = nq
if( n1==0_${ik}$ .or. n2==0_${ik}$ ) nw = 1_${ik}$
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( n1<0_${ik}$ .or. n1+n2/=nq ) then
info = -5_${ik}$
else if( n2<0_${ik}$ ) then
info = -6_${ik}$
else if( ldq<max( 1_${ik}$, nq ) ) then
info = -8_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = m*n
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNM22', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! degenerate cases (n1 = 0 or n2 = 0) are handled using stdlib${ii}$_${ci}$trmm.
if( n1==0_${ik}$ ) then
call stdlib${ii}$_${ci}$trmm( side, 'UPPER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc )
work( 1_${ik}$ ) = cone
return
else if( n2==0_${ik}$ ) then
call stdlib${ii}$_${ci}$trmm( side, 'LOWER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc )
work( 1_${ik}$ ) = cone
return
end if
! compute the largest chunk size available from the workspace.
nb = max( 1_${ik}$, min( lwork, lwkopt ) / nq )
if( left ) then
if( notran ) then
do i = 1, n, nb
len = min( nb, n-i+1 )
ldwork = m
! multiply bottom part of c by q12.
call stdlib${ii}$_${ci}$lacpy( 'ALL', n1, len, c( n2+1, i ), ldc, work,ldwork )
call stdlib${ii}$_${ci}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',n1, len, cone, &
q( 1_${ik}$, n2+1 ), ldq, work,ldwork )
! multiply top part of c by q11.
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,cone, q, ldq, &
c( 1_${ik}$, i ), ldc, cone, work,ldwork )
! multiply top part of c by q21.
call stdlib${ii}$_${ci}$lacpy( 'ALL', n2, len, c( 1_${ik}$, i ), ldc,work( n1+1 ), ldwork )
call stdlib${ii}$_${ci}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',n2, len, cone, &
q( n1+1, 1_${ik}$ ), ldq,work( n1+1 ), ldwork )
! multiply bottom part of c by q22.
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,cone, q( n1+1, &
n2+1 ), ldq, c( n2+1, i ), ldc,cone, work( n1+1 ), ldwork )
! copy everything back.
call stdlib${ii}$_${ci}$lacpy( 'ALL', m, len, work, ldwork, c( 1_${ik}$, i ),ldc )
end do
else
do i = 1, n, nb
len = min( nb, n-i+1 )
ldwork = m
! multiply bottom part of c by q21**h.
call stdlib${ii}$_${ci}$lacpy( 'ALL', n2, len, c( n1+1, i ), ldc, work,ldwork )
call stdlib${ii}$_${ci}$trmm( 'LEFT', 'UPPER', 'CONJUGATE', 'NON-UNIT',n2, len, cone, q( &
n1+1, 1_${ik}$ ), ldq, work,ldwork )
! multiply top part of c by q11**h.
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', n2, len, n1,cone, q, ldq, c( &
1_${ik}$, i ), ldc, cone, work,ldwork )
! multiply top part of c by q12**h.
call stdlib${ii}$_${ci}$lacpy( 'ALL', n1, len, c( 1_${ik}$, i ), ldc,work( n2+1 ), ldwork )
call stdlib${ii}$_${ci}$trmm( 'LEFT', 'LOWER', 'CONJUGATE', 'NON-UNIT',n1, len, cone, q( &
1_${ik}$, n2+1 ), ldq,work( n2+1 ), ldwork )
! multiply bottom part of c by q22**h.
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', n1, len, n2,cone, q( n1+1, n2+&
1_${ik}$ ), ldq, c( n1+1, i ), ldc,cone, work( n2+1 ), ldwork )
! copy everything back.
call stdlib${ii}$_${ci}$lacpy( 'ALL', m, len, work, ldwork, c( 1_${ik}$, i ),ldc )
end do
end if
else
if( notran ) then
do i = 1, m, nb
len = min( nb, m-i+1 )
ldwork = len
! multiply right part of c by q21.
call stdlib${ii}$_${ci}$lacpy( 'ALL', len, n2, c( i, n1+1 ), ldc, work,ldwork )
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',len, n2, cone,&
q( n1+1, 1_${ik}$ ), ldq, work,ldwork )
! multiply left part of c by q11.
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n2, n1,cone, c( i, 1_${ik}$ )&
, ldc, q, ldq, cone, work,ldwork )
! multiply left part of c by q12.
call stdlib${ii}$_${ci}$lacpy( 'ALL', len, n1, c( i, 1_${ik}$ ), ldc,work( 1_${ik}$ + n2*ldwork ), &
ldwork )
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',len, n1, cone,&
q( 1_${ik}$, n2+1 ), ldq,work( 1_${ik}$ + n2*ldwork ), ldwork )
! multiply right part of c by q22.
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n1, n2,cone, c( i, n1+&
1_${ik}$ ), ldc, q( n1+1, n2+1 ), ldq,cone, work( 1_${ik}$ + n2*ldwork ), ldwork )
! copy everything back.
call stdlib${ii}$_${ci}$lacpy( 'ALL', len, n, work, ldwork, c( i, 1_${ik}$ ),ldc )
end do
else
do i = 1, m, nb
len = min( nb, m-i+1 )
ldwork = len
! multiply right part of c by q12**h.
call stdlib${ii}$_${ci}$lacpy( 'ALL', len, n1, c( i, n2+1 ), ldc, work,ldwork )
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE', 'NON-UNIT',len, n1, cone, q(&
1_${ik}$, n2+1 ), ldq, work,ldwork )
! multiply left part of c by q11**h.
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE', len, n1, n2,cone, c( i, 1_${ik}$ ), &
ldc, q, ldq, cone, work,ldwork )
! multiply left part of c by q21**h.
call stdlib${ii}$_${ci}$lacpy( 'ALL', len, n2, c( i, 1_${ik}$ ), ldc,work( 1_${ik}$ + n1*ldwork ), &
ldwork )
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE', 'NON-UNIT',len, n2, cone, q(&
n1+1, 1_${ik}$ ), ldq,work( 1_${ik}$ + n1*ldwork ), ldwork )
! multiply right part of c by q22**h.
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE', len, n2, n1,cone, c( i, n2+1 )&
, ldc, q( n1+1, n2+1 ), ldq,cone, work( 1_${ik}$ + n1*ldwork ), ldwork )
! copy everything back.
call stdlib${ii}$_${ci}$lacpy( 'ALL', len, n, work, ldwork, c( i, 1_${ik}$ ),ldc )
end do
end if
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$)
return
end subroutine stdlib${ii}$_${ci}$unm22
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_orthogonal_factors_ql
