#:include "common.fypp" submodule(stdlib_lapack_orthogonal_factors) stdlib_lapack_orthogonal_factors_qr implicit none contains #:for ik,it,ii in LINALG_INT_KINDS_TYPES pure module subroutine stdlib${ii}$_sgeqr( m, n, a, lda, t, tsize, work, lwork,info ) !! SGEQR computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 ! 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}$, 'SGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ mintsz = n + 5_${ik}$ if ( mb>n .and. m>n ) then if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. if( ( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) .or. lwork<nb*n ).and. ( lwork>=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then if( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) ) then lminws = .true. nb = 1_${ik}$ mb = m end if if( lwork<nb*n ) then lminws = .true. nb = 1_${ik}$ end if 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}$, nb*n*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) & then info = -6_${ik}$ else if( ( lwork<max( 1_${ik}$, n*nb ) ) .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}$ ) = nb*n*nblcks + 5_${ik}$ end if t( 2_${ik}$ ) = mb t( 3_${ik}$ ) = nb if( minw ) then work( 1_${ik}$ ) = max( 1_${ik}$, n ) else work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SGEQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then return end if ! the qr decomposition if( ( m<=n ) .or. ( mb<=n ) .or. ( mb>=m ) ) then call stdlib${ii}$_sgeqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else call stdlib${ii}$_slatsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return end subroutine stdlib${ii}$_sgeqr pure module subroutine stdlib${ii}$_dgeqr( m, n, a, lda, t, tsize, work, lwork,info ) !! DGEQR computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 ! 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}$, 'DGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. if( ( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) .or. lwork<nb*n ).and. ( lwork>=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then if( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) ) then lminws = .true. nb = 1_${ik}$ mb = m end if if( lwork<nb*n ) then lminws = .true. nb = 1_${ik}$ end if 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}$, nb*n*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) & then info = -6_${ik}$ else if( ( lwork<max( 1_${ik}$, n*nb ) ) .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}$ ) = nb*n*nblcks + 5_${ik}$ end if t( 2_${ik}$ ) = mb t( 3_${ik}$ ) = nb if( minw ) then work( 1_${ik}$ ) = max( 1_${ik}$, n ) else work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then return end if ! the qr decomposition if( ( m<=n ) .or. ( mb<=n ) .or. ( mb>=m ) ) then call stdlib${ii}$_dgeqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else call stdlib${ii}$_dlatsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return end subroutine stdlib${ii}$_dgeqr #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$geqr( m, n, a, lda, t, tsize, work, lwork,info ) !! DGEQR: computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 ! 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}$, 'DGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. if( ( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) .or. lwork<nb*n ).and. ( lwork>=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then if( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) ) then lminws = .true. nb = 1_${ik}$ mb = m end if if( lwork<nb*n ) then lminws = .true. nb = 1_${ik}$ end if 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}$, nb*n*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) & then info = -6_${ik}$ else if( ( lwork<max( 1_${ik}$, n*nb ) ) .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}$ ) = nb*n*nblcks + 5_${ik}$ end if t( 2_${ik}$ ) = mb t( 3_${ik}$ ) = nb if( minw ) then work( 1_${ik}$ ) = max( 1_${ik}$, n ) else work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then return end if ! the qr decomposition if( ( m<=n ) .or. ( mb<=n ) .or. ( mb>=m ) ) then call stdlib${ii}$_${ri}$geqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else call stdlib${ii}$_${ri}$latsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return end subroutine stdlib${ii}$_${ri}$geqr #:endif #:endfor pure module subroutine stdlib${ii}$_cgeqr( m, n, a, lda, t, tsize, work, lwork,info ) !! CGEQR computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 ! 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}$, 'CGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. if( ( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) .or. lwork<nb*n ).and. ( lwork>=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then if( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) ) then lminws = .true. nb = 1_${ik}$ mb = m end if if( lwork<nb*n ) then lminws = .true. nb = 1_${ik}$ end if 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}$, nb*n*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) & then info = -6_${ik}$ else if( ( lwork<max( 1_${ik}$, n*nb ) ) .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}$ ) = nb*n*nblcks + 5_${ik}$ end if t( 2_${ik}$ ) = mb t( 3_${ik}$ ) = nb if( minw ) then work( 1_${ik}$ ) = max( 1_${ik}$, n ) else work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CGEQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then return end if ! the qr decomposition if( ( m<=n ) .or. ( mb<=n ) .or. ( mb>=m ) ) then call stdlib${ii}$_cgeqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else call stdlib${ii}$_clatsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return end subroutine stdlib${ii}$_cgeqr pure module subroutine stdlib${ii}$_zgeqr( m, n, a, lda, t, tsize, work, lwork,info ) !! ZGEQR computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 ! 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}$, 'ZGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. if( ( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) .or. lwork<nb*n ).and. ( lwork>=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then if( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) ) then lminws = .true. nb = 1_${ik}$ mb = m end if if( lwork<nb*n ) then lminws = .true. nb = 1_${ik}$ end if 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}$, nb*n*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) & then info = -6_${ik}$ else if( ( lwork<max( 1_${ik}$, n*nb ) ) .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}$ ) = nb*n*nblcks + 5_${ik}$ end if t( 2_${ik}$ ) = mb t( 3_${ik}$ ) = nb if( minw ) then work( 1_${ik}$ ) = max( 1_${ik}$, n ) else work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then return end if ! the qr decomposition if( ( m<=n ) .or. ( mb<=n ) .or. ( mb>=m ) ) then call stdlib${ii}$_zgeqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else call stdlib${ii}$_zlatsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return end subroutine stdlib${ii}$_zgeqr #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$geqr( m, n, a, lda, t, tsize, work, lwork,info ) !! ZGEQR: computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 ! 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}$, 'ZGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. if( ( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) .or. lwork<nb*n ).and. ( lwork>=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then if( tsize<max( 1_${ik}$, nb*n*nblcks + 5_${ik}$ ) ) then lminws = .true. nb = 1_${ik}$ mb = m end if if( lwork<nb*n ) then lminws = .true. nb = 1_${ik}$ end if 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}$, nb*n*nblcks + 5_${ik}$ ).and. ( .not.lquery ) .and. ( .not.lminws ) ) & then info = -6_${ik}$ else if( ( lwork<max( 1_${ik}$, n*nb ) ) .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}$ ) = nb*n*nblcks + 5_${ik}$ end if t( 2_${ik}$ ) = mb t( 3_${ik}$ ) = nb if( minw ) then work( 1_${ik}$ ) = max( 1_${ik}$, n ) else work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then return end if ! the qr decomposition if( ( m<=n ) .or. ( mb<=n ) .or. ( mb>=m ) ) then call stdlib${ii}$_${ci}$geqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else call stdlib${ii}$_${ci}$latsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return end subroutine stdlib${ii}$_${ci}$geqr #:endif #:endfor pure module subroutine stdlib${ii}$_sgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! SGEMQR 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 tall skinny !! QR factorization (SGEQR) 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 * nb mn = m else lw = mb * nb mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else nblcks = ( mn - k ) / ( mb - 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}$, mn ) ) 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( 'SGEMQR', -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. ( mb<=k ) .or. ( mb>=max( m, n, & k ) ) ) then call stdlib${ii}$_sgemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else call stdlib${ii}$_slamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if work( 1_${ik}$ ) = lw return end subroutine stdlib${ii}$_sgemqr pure module subroutine stdlib${ii}$_dgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! DGEMQR 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 tall skinny !! QR factorization (DGEQR) 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 * nb mn = m else lw = mb * nb mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else nblcks = ( mn - k ) / ( mb - 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}$, mn ) ) 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( 'DGEMQR', -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. ( mb<=k ) .or. ( mb>=max( m, n, & k ) ) ) then call stdlib${ii}$_dgemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else call stdlib${ii}$_dlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if work( 1_${ik}$ ) = lw return end subroutine stdlib${ii}$_dgemqr #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$gemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! DGEMQR: 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 tall skinny !! QR factorization (DGEQR) 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 * nb mn = m else lw = mb * nb mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else nblcks = ( mn - k ) / ( mb - 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}$, mn ) ) 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( 'DGEMQR', -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. ( mb<=k ) .or. ( mb>=max( m, n, & k ) ) ) then call stdlib${ii}$_${ri}$gemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else call stdlib${ii}$_${ri}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if work( 1_${ik}$ ) = lw return end subroutine stdlib${ii}$_${ri}$gemqr #:endif #:endfor pure module subroutine stdlib${ii}$_cgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! CGEMQR overwrites the general real 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 tall skinny !! QR factorization (CGEQR) 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 * nb mn = m else lw = mb * nb mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else nblcks = ( mn - k ) / ( mb - 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}$, mn ) ) 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( 'CGEMQR', -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. ( mb<=k ) .or. ( mb>=max( m, n, & k ) ) ) then call stdlib${ii}$_cgemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else call stdlib${ii}$_clamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if work( 1_${ik}$ ) = lw return end subroutine stdlib${ii}$_cgemqr pure module subroutine stdlib${ii}$_zgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! ZGEMQR overwrites the general real 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 tall skinny !! QR factorization (ZGEQR) 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 * nb mn = m else lw = mb * nb mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else nblcks = ( mn - k ) / ( mb - 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}$, mn ) ) 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( 'ZGEMQR', -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. ( mb<=k ) .or. ( mb>=max( m, n, & k ) ) ) then call stdlib${ii}$_zgemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else call stdlib${ii}$_zlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if work( 1_${ik}$ ) = lw return end subroutine stdlib${ii}$_zgemqr #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$gemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! ZGEMQR: overwrites the general real 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 tall skinny !! QR factorization (ZGEQR) 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 * nb mn = m else lw = mb * nb mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else nblcks = ( mn - k ) / ( mb - 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}$, mn ) ) 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( 'ZGEMQR', -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. ( mb<=k ) .or. ( mb>=max( m, n, & k ) ) ) then call stdlib${ii}$_${ci}$gemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else call stdlib${ii}$_${ci}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if work( 1_${ik}$ ) = lw return end subroutine stdlib${ii}$_${ci}$gemqr #:endif #:endfor pure module subroutine stdlib${ii}$_sgeqrf( m, n, a, lda, tau, work, lwork, info ) !! SGEQRF computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 k = min( m, n ) info = 0_${ik}$ nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', m, n, -1_${ik}$, -1_${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}$ else if( .not.lquery ) then if( lwork<=0_${ik}$ .or. ( m>0_${ik}$ .and. lwork<max( 1_${ik}$, n ) ) )info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SGEQRF', -info ) return else if( lquery ) then if( k==0_${ik}$ ) then lwkopt = 1_${ik}$ else lwkopt = n*nb end if work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible if( k==0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ 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}$, 'SGEQRF', ' ', 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}$, 'SGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_sgeqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_slarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_slarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-i-& ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$_sgeqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_sgeqrf pure module subroutine stdlib${ii}$_dgeqrf( m, n, a, lda, tau, work, lwork, info ) !! DGEQRF computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 k = min( m, n ) info = 0_${ik}$ nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', m, n, -1_${ik}$, -1_${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}$ else if( .not.lquery ) then if( lwork<=0_${ik}$ .or. ( m>0_${ik}$ .and. lwork<max( 1_${ik}$, n ) ) )info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRF', -info ) return else if( lquery ) then if( k==0_${ik}$ ) then lwkopt = 1_${ik}$ else lwkopt = n*nb end if work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible if( k==0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ 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}$, 'DGEQRF', ' ', 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}$, 'DGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_dgeqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_dlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_dlarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-i-& ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$_dgeqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_dgeqrf #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$geqrf( m, n, a, lda, tau, work, lwork, info ) !! DGEQRF: computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 k = min( m, n ) info = 0_${ik}$ nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', m, n, -1_${ik}$, -1_${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}$ else if( .not.lquery ) then if( lwork<=0_${ik}$ .or. ( m>0_${ik}$ .and. lwork<max( 1_${ik}$, n ) ) )info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRF', -info ) return else if( lquery ) then if( k==0_${ik}$ ) then lwkopt = 1_${ik}$ else lwkopt = n*nb end if work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible if( k==0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ 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}$, 'DGEQRF', ' ', 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}$, 'DGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_${ri}$geqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) 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', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-i-& ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$geqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_${ri}$geqrf #:endif #:endfor pure module subroutine stdlib${ii}$_cgeqrf( m, n, a, lda, tau, work, lwork, info ) !! CGEQRF computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 k = min( m, n ) info = 0_${ik}$ nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', m, n, -1_${ik}$, -1_${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}$ else if( .not.lquery ) then if( lwork<=0_${ik}$ .or. ( m>0_${ik}$ .and. lwork<max( 1_${ik}$, n ) ) )info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CGEQRF', -info ) return else if( lquery ) then if( k==0_${ik}$ ) then lwkopt = 1_${ik}$ else lwkopt = n*nb end if work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible if( k==0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ 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}$, 'CGEQRF', ' ', 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}$, 'CGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_cgeqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_clarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_clarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE', m-& i+1, n-i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$_cgeqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_cgeqrf pure module subroutine stdlib${ii}$_zgeqrf( m, n, a, lda, tau, work, lwork, info ) !! ZGEQRF computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 k = min( m, n ) info = 0_${ik}$ nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${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}$ else if( .not.lquery ) then if( lwork<=0_${ik}$ .or. ( m>0_${ik}$ .and. lwork<max( 1_${ik}$, n ) ) )info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRF', -info ) return else if( lquery ) then if( k==0_${ik}$ ) then lwkopt = 1_${ik}$ else lwkopt = n*nb end if work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible if( k==0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ 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}$, 'ZGEQRF', ' ', 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}$, 'ZGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_zgeqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_zlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_zlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE', m-& i+1, n-i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$_zgeqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_zgeqrf #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$geqrf( m, n, a, lda, tau, work, lwork, info ) !! ZGEQRF: computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N 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 k = min( m, n ) info = 0_${ik}$ nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${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}$ else if( .not.lquery ) then if( lwork<=0_${ik}$ .or. ( m>0_${ik}$ .and. lwork<max( 1_${ik}$, n ) ) )info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRF', -info ) return else if( lquery ) then if( k==0_${ik}$ ) then lwkopt = 1_${ik}$ else lwkopt = n*nb end if work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible if( k==0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ 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}$, 'ZGEQRF', ' ', 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}$, 'ZGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_${ci}$geqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) 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', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE', m-& i+1, n-i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$geqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_${ci}$geqrf #:endif #:endfor pure module subroutine stdlib${ii}$_sgeqr2( m, n, a, lda, tau, work, info ) !! SGEQR2 computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix; !! 0 is a (m-n)-by-n 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( 'SGEQR2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one call stdlib${ii}$_slarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) a( i, i ) = aii end if end do return end subroutine stdlib${ii}$_sgeqr2 pure module subroutine stdlib${ii}$_dgeqr2( m, n, a, lda, tau, work, info ) !! DGEQR2 computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix; !! 0 is a (m-n)-by-n 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( 'DGEQR2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one call stdlib${ii}$_dlarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) a( i, i ) = aii end if end do return end subroutine stdlib${ii}$_dgeqr2 #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$geqr2( m, n, a, lda, tau, work, info ) !! DGEQR2: computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix; !! 0 is a (m-n)-by-n 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( 'DGEQR2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one call stdlib${ii}$_${ri}$larf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) a( i, i ) = aii end if end do return end subroutine stdlib${ii}$_${ri}$geqr2 #:endif #:endfor pure module subroutine stdlib${ii}$_cgeqr2( m, n, a, lda, tau, work, info ) !! CGEQR2 computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix; !! 0 is a (m-n)-by-n 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( 'CGEQR2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_clarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i)**h to a(i:m,i+1:n) from the left alpha = a( i, i ) a( i, i ) = cone call stdlib${ii}$_clarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$,conjg( tau( i ) ), a( i, i+1 & ), lda, work ) a( i, i ) = alpha end if end do return end subroutine stdlib${ii}$_cgeqr2 pure module subroutine stdlib${ii}$_zgeqr2( m, n, a, lda, tau, work, info ) !! ZGEQR2 computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix; !! 0 is a (m-n)-by-n 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( 'ZGEQR2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_zlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i)**h to a(i:m,i+1:n) from the left alpha = a( i, i ) a( i, i ) = cone call stdlib${ii}$_zlarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$,conjg( tau( i ) ), a( i, i+1 & ), lda, work ) a( i, i ) = alpha end if end do return end subroutine stdlib${ii}$_zgeqr2 #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$geqr2( m, n, a, lda, tau, work, info ) !! ZGEQR2: computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix; !! 0 is a (m-n)-by-n 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( 'ZGEQR2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_${ci}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i)**h to a(i:m,i+1:n) from the left alpha = a( i, i ) a( i, i ) = cone call stdlib${ii}$_${ci}$larf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$,conjg( tau( i ) ), a( i, i+1 & ), lda, work ) a( i, i ) = alpha end if end do return end subroutine stdlib${ii}$_${ci}$geqr2 #:endif #:endfor pure module subroutine stdlib${ii}$_cungqr( m, n, k, a, lda, tau, work, lwork, info ) !! CUNGQR generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M !! Q = H(1) H(2) . . . H(k) !! as returned by CGEQRF. ! -- lapack computational routine -- ! -- lapack 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}$, 'CUNGQR', ' ', m, n, k, -1_${ik}$ ) lwkopt = max( 1_${ik}$, n )*nb work( 1_${ik}$ ) = lwkopt 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}$ else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then info = -8_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CUNGQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( n<=0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ return end if 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}$, 'CUNGQR', ' ', 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}$, 'CUNGQR', ' ', 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 columns are handled by the block method. ki = ( ( k-nx-1 ) / nb )*nb kk = min( k, ki+nb ) ! set a(1:kk,kk+1:n) to czero. do j = kk + 1, n do i = 1, kk 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<n )call stdlib${ii}$_cung2r( 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<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_clarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left call stdlib${ii}$_clarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block call stdlib${ii}$_cung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to czero do j = i, i + ib - 1 do l = 1, i - 1 a( l, j ) = czero end do end do end do end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_cungqr pure module subroutine stdlib${ii}$_zungqr( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M !! Q = H(1) H(2) . . . H(k) !! as returned by ZGEQRF. ! -- lapack computational routine -- ! -- lapack 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}$, 'ZUNGQR', ' ', m, n, k, -1_${ik}$ ) lwkopt = max( 1_${ik}$, n )*nb work( 1_${ik}$ ) = lwkopt 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}$ else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then info = -8_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZUNGQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( n<=0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ return end if 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}$, 'ZUNGQR', ' ', 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}$, 'ZUNGQR', ' ', 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 columns are handled by the block method. ki = ( ( k-nx-1 ) / nb )*nb kk = min( k, ki+nb ) ! set a(1:kk,kk+1:n) to czero. do j = kk + 1, n do i = 1, kk 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<n )call stdlib${ii}$_zung2r( 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<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_zlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left call stdlib${ii}$_zlarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block call stdlib${ii}$_zung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to czero do j = i, i + ib - 1 do l = 1, i - 1 a( l, j ) = czero end do end do end do end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_zungqr #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$ungqr( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGQR: generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M !! Q = H(1) H(2) . . . H(k) !! as returned by ZGEQRF. ! -- lapack computational routine -- ! -- lapack 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}$, 'ZUNGQR', ' ', m, n, k, -1_${ik}$ ) lwkopt = max( 1_${ik}$, n )*nb work( 1_${ik}$ ) = lwkopt 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}$ else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then info = -8_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZUNGQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( n<=0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ return end if 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}$, 'ZUNGQR', ' ', 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}$, 'ZUNGQR', ' ', 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 columns are handled by the block method. ki = ( ( k-nx-1 ) / nb )*nb kk = min( k, ki+nb ) ! set a(1:kk,kk+1:n) to czero. do j = kk + 1, n do i = 1, kk 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<n )call stdlib${ii}$_${ci}$ung2r( 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<=n ) 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', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left call stdlib${ii}$_${ci}$larfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block call stdlib${ii}$_${ci}$ung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to czero do j = i, i + ib - 1 do l = 1, i - 1 a( l, j ) = czero end do end do end do end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_${ci}$ungqr #:endif #:endfor pure module subroutine stdlib${ii}$_cung2r( m, n, k, a, lda, tau, work, info ) !! CUNG2R generates an m by n complex matrix Q with orthonormal columns, !! which is defined as the first n columns of a product of k elementary !! reflectors of order m !! Q = H(1) H(2) . . . H(k) !! as returned by CGEQRF. ! -- lapack computational routine -- ! -- lapack 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<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( 'CUNG2R', -info ) return end if ! quick return if possible if( n<=0 )return ! initialise columns k+1:n to columns of the unit matrix do j = k + 1, n do l = 1, m a( l, j ) = czero end do a( j, j ) = cone end do do i = k, 1, -1 ! apply h(i) to a(i:m,i:n) from the left if( i<n ) then a( i, i ) = cone call stdlib${ii}$_clarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) end if if( i<m )call stdlib${ii}$_cscal( m-i, -tau( i ), a( i+1, i ), 1_${ik}$ ) a( i, i ) = cone - tau( i ) ! set a(1:i-1,i) to czero do l = 1, i - 1 a( l, i ) = czero end do end do return end subroutine stdlib${ii}$_cung2r pure module subroutine stdlib${ii}$_zung2r( m, n, k, a, lda, tau, work, info ) !! ZUNG2R generates an m by n complex matrix Q with orthonormal columns, !! which is defined as the first n columns of a product of k elementary !! reflectors of order m !! Q = H(1) H(2) . . . H(k) !! as returned by ZGEQRF. ! -- lapack computational routine -- ! -- lapack 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<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( 'ZUNG2R', -info ) return end if ! quick return if possible if( n<=0 )return ! initialise columns k+1:n to columns of the unit matrix do j = k + 1, n do l = 1, m a( l, j ) = czero end do a( j, j ) = cone end do do i = k, 1, -1 ! apply h(i) to a(i:m,i:n) from the left if( i<n ) then a( i, i ) = cone call stdlib${ii}$_zlarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) end if if( i<m )call stdlib${ii}$_zscal( m-i, -tau( i ), a( i+1, i ), 1_${ik}$ ) a( i, i ) = cone - tau( i ) ! set a(1:i-1,i) to czero do l = 1, i - 1 a( l, i ) = czero end do end do return end subroutine stdlib${ii}$_zung2r #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$ung2r( m, n, k, a, lda, tau, work, info ) !! ZUNG2R: generates an m by n complex matrix Q with orthonormal columns, !! which is defined as the first n columns of a product of k elementary !! reflectors of order m !! Q = H(1) H(2) . . . H(k) !! as returned by ZGEQRF. ! -- lapack computational routine -- ! -- lapack 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<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( 'ZUNG2R', -info ) return end if ! quick return if possible if( n<=0 )return ! initialise columns k+1:n to columns of the unit matrix do j = k + 1, n do l = 1, m a( l, j ) = czero end do a( j, j ) = cone end do do i = k, 1, -1 ! apply h(i) to a(i:m,i:n) from the left if( i<n ) then a( i, i ) = cone call stdlib${ii}$_${ci}$larf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) end if if( i<m )call stdlib${ii}$_${ci}$scal( m-i, -tau( i ), a( i+1, i ), 1_${ik}$ ) a( i, i ) = cone - tau( i ) ! set a(1:i-1,i) to czero do l = 1, i - 1 a( l, i ) = czero end do end do return end subroutine stdlib${ii}$_${ci}$ung2r #:endif #:endfor pure module subroutine stdlib${ii}$_cunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! CUNMQR 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) !! as returned by CGEQRF. 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, 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}$, 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 nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', 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( 'CUNMQR', -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}$, 'CUNMQR', side // trans, m, n, k,-1_${ik}$ ) ) end if end if if( nb<nbmin .or. nb>=k ) then ! use unblocked code call stdlib${ii}$_cunm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. 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 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', 'COLUMNWISE', 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, trans, 'FORWARD', 'COLUMNWISE', 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}$_cunmqr pure module subroutine stdlib${ii}$_zunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMQR 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) !! as returned by ZGEQRF. 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, 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}$, 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 nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 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( 'ZUNMQR', -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}$, 'ZUNMQR', side // trans, m, n, k,-1_${ik}$ ) ) end if end if if( nb<nbmin .or. nb>=k ) then ! use unblocked code call stdlib${ii}$_zunm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. 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 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', 'COLUMNWISE', 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, trans, 'FORWARD', 'COLUMNWISE', 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}$_zunmqr #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$unmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMQR: 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) !! as returned by ZGEQRF. 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, 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}$, 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 nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 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( 'ZUNMQR', -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}$, 'ZUNMQR', 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}$unm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. 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 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', 'COLUMNWISE', 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, trans, 'FORWARD', 'COLUMNWISE', 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}$unmqr #:endif #:endfor pure module subroutine stdlib${ii}$_cunm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! CUNM2R 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(1) H(2) . . . H(k) !! as returned by CGEQRF. 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}$, 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( 'CUNM2R', -info ) return end if ! quick return if possible if( m==0 .or. n==0 .or. k==0 )return if( ( left .and. .not.notran .or. .not.left .and. 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 = tau( i ) else taui = conjg( tau( i ) ) end if aii = a( i, i ) a( i, i ) = cone call stdlib${ii}$_clarf( side, mi, ni, a( i, i ), 1_${ik}$, taui, c( ic, jc ), ldc,work ) a( i, i ) = aii end do return end subroutine stdlib${ii}$_cunm2r pure module subroutine stdlib${ii}$_zunm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! ZUNM2R 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(1) H(2) . . . H(k) !! as returned by ZGEQRF. 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}$, 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( 'ZUNM2R', -info ) return end if ! quick return if possible if( m==0 .or. n==0 .or. k==0 )return if( ( left .and. .not.notran .or. .not.left .and. 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 = tau( i ) else taui = conjg( tau( i ) ) end if aii = a( i, i ) a( i, i ) = cone call stdlib${ii}$_zlarf( side, mi, ni, a( i, i ), 1_${ik}$, taui, c( ic, jc ), ldc,work ) a( i, i ) = aii end do return end subroutine stdlib${ii}$_zunm2r #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$unm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! ZUNM2R: 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(1) H(2) . . . H(k) !! as returned by ZGEQRF. 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}$, 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( 'ZUNM2R', -info ) return end if ! quick return if possible if( m==0 .or. n==0 .or. k==0 )return if( ( left .and. .not.notran .or. .not.left .and. 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 = tau( i ) else taui = conjg( tau( i ) ) end if aii = a( i, i ) a( i, i ) = cone call stdlib${ii}$_${ci}$larf( side, mi, ni, a( i, i ), 1_${ik}$, taui, c( ic, jc ), ldc,work ) a( i, i ) = aii end do return end subroutine stdlib${ii}$_${ci}$unm2r #:endif #:endfor pure module subroutine stdlib${ii}$_sorgqr( m, n, k, a, lda, tau, work, lwork, info ) !! SORGQR generates an M-by-N real matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M !! Q = H(1) H(2) . . . H(k) !! as returned by SGEQRF. ! -- lapack computational routine -- ! -- lapack 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}$, 'SORGQR', ' ', m, n, k, -1_${ik}$ ) lwkopt = max( 1_${ik}$, n )*nb work( 1_${ik}$ ) = lwkopt 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}$ else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then info = -8_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SORGQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( n<=0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ return end if 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}$, 'SORGQR', ' ', 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}$, 'SORGQR', ' ', 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 columns are handled by the block method. ki = ( ( k-nx-1 ) / nb )*nb kk = min( k, ki+nb ) ! set a(1:kk,kk+1:n) to zero. do j = kk + 1, n do i = 1, kk 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<n )call stdlib${ii}$_sorg2r( 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<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_slarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left call stdlib${ii}$_slarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block call stdlib${ii}$_sorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to zero do j = i, i + ib - 1 do l = 1, i - 1 a( l, j ) = zero end do end do end do end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_sorgqr pure module subroutine stdlib${ii}$_dorgqr( m, n, k, a, lda, tau, work, lwork, info ) !! DORGQR generates an M-by-N real matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M !! Q = H(1) H(2) . . . H(k) !! as returned by DGEQRF. ! -- lapack computational routine -- ! -- lapack 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}$, 'DORGQR', ' ', m, n, k, -1_${ik}$ ) lwkopt = max( 1_${ik}$, n )*nb work( 1_${ik}$ ) = lwkopt 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}$ else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then info = -8_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DORGQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( n<=0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ return end if 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}$, 'DORGQR', ' ', 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}$, 'DORGQR', ' ', 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 columns are handled by the block method. ki = ( ( k-nx-1 ) / nb )*nb kk = min( k, ki+nb ) ! set a(1:kk,kk+1:n) to zero. do j = kk + 1, n do i = 1, kk 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<n )call stdlib${ii}$_dorg2r( 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<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_dlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left call stdlib${ii}$_dlarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block call stdlib${ii}$_dorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to zero do j = i, i + ib - 1 do l = 1, i - 1 a( l, j ) = zero end do end do end do end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_dorgqr #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$orgqr( m, n, k, a, lda, tau, work, lwork, info ) !! DORGQR: generates an M-by-N real matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M !! Q = H(1) H(2) . . . H(k) !! as returned by DGEQRF. ! -- lapack computational routine -- ! -- lapack 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}$, 'DORGQR', ' ', m, n, k, -1_${ik}$ ) lwkopt = max( 1_${ik}$, n )*nb work( 1_${ik}$ ) = lwkopt 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}$ else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then info = -8_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DORGQR', -info ) return else if( lquery ) then return end if ! quick return if possible if( n<=0_${ik}$ ) then work( 1_${ik}$ ) = 1_${ik}$ return end if 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}$, 'DORGQR', ' ', 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}$, 'DORGQR', ' ', 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 columns are handled by the block method. ki = ( ( k-nx-1 ) / nb )*nb kk = min( k, ki+nb ) ! set a(1:kk,kk+1:n) to zero. do j = kk + 1, n do i = 1, kk 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<n )call stdlib${ii}$_${ri}$org2r( 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<=n ) 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', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left call stdlib${ii}$_${ri}$larfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block call stdlib${ii}$_${ri}$org2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to zero do j = i, i + ib - 1 do l = 1, i - 1 a( l, j ) = zero end do end do end do end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_${ri}$orgqr #:endif #:endfor pure module subroutine stdlib${ii}$_sorg2r( m, n, k, a, lda, tau, work, info ) !! SORG2R generates an m by n real matrix Q with orthonormal columns, !! which is defined as the first n columns of a product of k elementary !! reflectors of order m !! Q = H(1) H(2) . . . H(k) !! as returned by SGEQRF. ! -- lapack computational routine -- ! -- lapack 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<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( 'SORG2R', -info ) return end if ! quick return if possible if( n<=0 )return ! initialise columns k+1:n to columns of the unit matrix do j = k + 1, n do l = 1, m a( l, j ) = zero end do a( j, j ) = one end do do i = k, 1, -1 ! apply h(i) to a(i:m,i:n) from the left if( i<n ) then a( i, i ) = one call stdlib${ii}$_slarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) end if if( i<m )call stdlib${ii}$_sscal( m-i, -tau( i ), a( i+1, i ), 1_${ik}$ ) a( i, i ) = one - tau( i ) ! set a(1:i-1,i) to zero do l = 1, i - 1 a( l, i ) = zero end do end do return end subroutine stdlib${ii}$_sorg2r pure module subroutine stdlib${ii}$_dorg2r( m, n, k, a, lda, tau, work, info ) !! DORG2R generates an m by n real matrix Q with orthonormal columns, !! which is defined as the first n columns of a product of k elementary !! reflectors of order m !! Q = H(1) H(2) . . . H(k) !! as returned by DGEQRF. ! -- lapack computational routine -- ! -- lapack 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<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( 'DORG2R', -info ) return end if ! quick return if possible if( n<=0 )return ! initialise columns k+1:n to columns of the unit matrix do j = k + 1, n do l = 1, m a( l, j ) = zero end do a( j, j ) = one end do do i = k, 1, -1 ! apply h(i) to a(i:m,i:n) from the left if( i<n ) then a( i, i ) = one call stdlib${ii}$_dlarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) end if if( i<m )call stdlib${ii}$_dscal( m-i, -tau( i ), a( i+1, i ), 1_${ik}$ ) a( i, i ) = one - tau( i ) ! set a(1:i-1,i) to zero do l = 1, i - 1 a( l, i ) = zero end do end do return end subroutine stdlib${ii}$_dorg2r #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$org2r( m, n, k, a, lda, tau, work, info ) !! DORG2R: generates an m by n real matrix Q with orthonormal columns, !! which is defined as the first n columns of a product of k elementary !! reflectors of order m !! Q = H(1) H(2) . . . H(k) !! as returned by DGEQRF. ! -- lapack computational routine -- ! -- lapack 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<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( 'DORG2R', -info ) return end if ! quick return if possible if( n<=0 )return ! initialise columns k+1:n to columns of the unit matrix do j = k + 1, n do l = 1, m a( l, j ) = zero end do a( j, j ) = one end do do i = k, 1, -1 ! apply h(i) to a(i:m,i:n) from the left if( i<n ) then a( i, i ) = one call stdlib${ii}$_${ri}$larf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) end if if( i<m )call stdlib${ii}$_${ri}$scal( m-i, -tau( i ), a( i+1, i ), 1_${ik}$ ) a( i, i ) = one - tau( i ) ! set a(1:i-1,i) to zero do l = 1, i - 1 a( l, i ) = zero end do end do return end subroutine stdlib${ii}$_${ri}$org2r #:endif #:endfor pure module subroutine stdlib${ii}$_sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! SORMQR 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) !! as returned by SGEQRF. 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, 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}$, 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 nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', 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( 'SORMQR', -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}$, 'SORMQR', side // trans, m, n, k,-1_${ik}$ ) ) end if end if if( nb<nbmin .or. nb>=k ) then ! use unblocked code call stdlib${ii}$_sorm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. 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 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', 'COLUMNWISE', 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, trans, 'FORWARD', 'COLUMNWISE', 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}$_sormqr pure module subroutine stdlib${ii}$_dormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! DORMQR 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) !! as returned by DGEQRF. 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, 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}$, 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 nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', 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( 'DORMQR', -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}$, 'DORMQR', side // trans, m, n, k,-1_${ik}$ ) ) end if end if if( nb<nbmin .or. nb>=k ) then ! use unblocked code call stdlib${ii}$_dorm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. 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 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', 'COLUMNWISE', 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, trans, 'FORWARD', 'COLUMNWISE', 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}$_dormqr #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$ormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! DORMQR: 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) !! as returned by DGEQRF. 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, 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}$, 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 nb = min( nbmax, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', 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( 'DORMQR', -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}$, 'DORMQR', 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}$orm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. 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 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', 'COLUMNWISE', 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, trans, 'FORWARD', 'COLUMNWISE', 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}$ormqr #:endif #:endfor pure module subroutine stdlib${ii}$_sorm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! SORM2R 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(1) H(2) . . . H(k) !! as returned by SGEQRF. 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}$, 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( 'SORM2R', -info ) return end if ! quick return if possible if( m==0 .or. n==0 .or. k==0 )return if( ( left .and. .not.notran ) .or. ( .not.left .and. 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 ), 1_${ik}$, tau( i ), c( ic, jc ),ldc, work ) a( i, i ) = aii end do return end subroutine stdlib${ii}$_sorm2r pure module subroutine stdlib${ii}$_dorm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! DORM2R 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(1) H(2) . . . H(k) !! as returned by DGEQRF. 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}$, 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( 'DORM2R', -info ) return end if ! quick return if possible if( m==0 .or. n==0 .or. k==0 )return if( ( left .and. .not.notran ) .or. ( .not.left .and. 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 ), 1_${ik}$, tau( i ), c( ic, jc ),ldc, work ) a( i, i ) = aii end do return end subroutine stdlib${ii}$_dorm2r #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$orm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! DORM2R: 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(1) H(2) . . . H(k) !! as returned by DGEQRF. 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}$, 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( 'DORM2R', -info ) return end if ! quick return if possible if( m==0 .or. n==0 .or. k==0 )return if( ( left .and. .not.notran ) .or. ( .not.left .and. 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 ), 1_${ik}$, tau( i ), c( ic, jc ),ldc, work ) a( i, i ) = aii end do return end subroutine stdlib${ii}$_${ri}$orm2r #:endif #:endfor pure module subroutine stdlib${ii}$_sgeqrt( m, n, nb, a, lda, t, ldt, work, info ) !! SGEQRT computes a blocked QR 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, nb ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk), parameter :: use_recursive_qr = .true. 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( nb<1_${ik}$ .or. ( nb>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<nb ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SGEQRT', -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, nb ib = min( k-i+1, nb ) ! compute the qr factorization of the current block a(i:m,i:i+ib-1) if( use_recursive_qr ) then call stdlib${ii}$_sgeqrt3( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) else call stdlib${ii}$_sgeqrt2( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) end if if( i+ib<=n ) then ! update by applying h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_slarfb( 'L', 'T', 'F', 'C', m-i+1, n-i-ib+1, ib,a( i, i ), lda, t( 1_${ik}$,& i ), ldt,a( i, i+ib ), lda, work , n-i-ib+1 ) end if end do return end subroutine stdlib${ii}$_sgeqrt pure module subroutine stdlib${ii}$_dgeqrt( m, n, nb, a, lda, t, ldt, work, info ) !! DGEQRT computes a blocked QR 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, nb ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk), parameter :: use_recursive_qr = .true. 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( nb<1_${ik}$ .or. ( nb>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<nb ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRT', -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, nb ib = min( k-i+1, nb ) ! compute the qr factorization of the current block a(i:m,i:i+ib-1) if( use_recursive_qr ) then call stdlib${ii}$_dgeqrt3( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) else call stdlib${ii}$_dgeqrt2( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) end if if( i+ib<=n ) then ! update by applying h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_dlarfb( 'L', 'T', 'F', 'C', m-i+1, n-i-ib+1, ib,a( i, i ), lda, t( 1_${ik}$,& i ), ldt,a( i, i+ib ), lda, work , n-i-ib+1 ) end if end do return end subroutine stdlib${ii}$_dgeqrt #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$geqrt( m, n, nb, a, lda, t, ldt, work, info ) !! DGEQRT: computes a blocked QR 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, nb ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk), parameter :: use_recursive_qr = .true. 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( nb<1_${ik}$ .or. ( nb>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<nb ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRT', -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, nb ib = min( k-i+1, nb ) ! compute the qr factorization of the current block a(i:m,i:i+ib-1) if( use_recursive_qr ) then call stdlib${ii}$_${ri}$geqrt3( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) else call stdlib${ii}$_${ri}$geqrt2( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) end if if( i+ib<=n ) then ! update by applying h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_${ri}$larfb( 'L', 'T', 'F', 'C', m-i+1, n-i-ib+1, ib,a( i, i ), lda, t( 1_${ik}$,& i ), ldt,a( i, i+ib ), lda, work , n-i-ib+1 ) end if end do return end subroutine stdlib${ii}$_${ri}$geqrt #:endif #:endfor pure module subroutine stdlib${ii}$_cgeqrt( m, n, nb, a, lda, t, ldt, work, info ) !! CGEQRT computes a blocked QR 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, nb ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk), parameter :: use_recursive_qr = .true. 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( nb<1_${ik}$ .or. ( nb>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<nb ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CGEQRT', -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, nb ib = min( k-i+1, nb ) ! compute the qr factorization of the current block a(i:m,i:i+ib-1) if( use_recursive_qr ) then call stdlib${ii}$_cgeqrt3( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) else call stdlib${ii}$_cgeqrt2( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) end if if( i+ib<=n ) then ! update by applying h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_clarfb( 'L', 'C', 'F', 'C', m-i+1, n-i-ib+1, ib,a( i, i ), lda, t( 1_${ik}$,& i ), ldt,a( i, i+ib ), lda, work , n-i-ib+1 ) end if end do return end subroutine stdlib${ii}$_cgeqrt pure module subroutine stdlib${ii}$_zgeqrt( m, n, nb, a, lda, t, ldt, work, info ) !! ZGEQRT computes a blocked QR 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, nb ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk), parameter :: use_recursive_qr = .true. 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( nb<1_${ik}$ .or. ( nb>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<nb ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRT', -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, nb ib = min( k-i+1, nb ) ! compute the qr factorization of the current block a(i:m,i:i+ib-1) if( use_recursive_qr ) then call stdlib${ii}$_zgeqrt3( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) else call stdlib${ii}$_zgeqrt2( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) end if if( i+ib<=n ) then ! update by applying h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_zlarfb( 'L', 'C', 'F', 'C', m-i+1, n-i-ib+1, ib,a( i, i ), lda, t( 1_${ik}$,& i ), ldt,a( i, i+ib ), lda, work , n-i-ib+1 ) end if end do return end subroutine stdlib${ii}$_zgeqrt #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$geqrt( m, n, nb, a, lda, t, ldt, work, info ) !! ZGEQRT: computes a blocked QR 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, nb ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk), parameter :: use_recursive_qr = .true. 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( nb<1_${ik}$ .or. ( nb>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<nb ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRT', -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, nb ib = min( k-i+1, nb ) ! compute the qr factorization of the current block a(i:m,i:i+ib-1) if( use_recursive_qr ) then call stdlib${ii}$_${ci}$geqrt3( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) else call stdlib${ii}$_${ci}$geqrt2( m-i+1, ib, a(i,i), lda, t(1_${ik}$,i), ldt, iinfo ) end if if( i+ib<=n ) then ! update by applying h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_${ci}$larfb( 'L', 'C', 'F', 'C', m-i+1, n-i-ib+1, ib,a( i, i ), lda, t( 1_${ik}$,& i ), ldt,a( i, i+ib ), lda, work , n-i-ib+1 ) end if end do return end subroutine stdlib${ii}$_${ci}$geqrt #:endif #:endfor pure module subroutine stdlib${ii}$_sgeqrt2( m, n, a, lda, t, ldt, info ) !! SGEQRT2 computes a QR 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 ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, k real(sp) :: aii, alpha ! Executable Statements ! test the input arguments info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ else if( m<n ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SGEQRT2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elem. refl. h(i) to annihilate a(i+1:m,i), tau(i) -> t(i,1) call stdlib${ii}$_slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one ! w(1:n-i) := a(i:m,i+1:n)^h * a(i:m,i) [w = t(:,n)] call stdlib${ii}$_sgemv( 'T',m-i+1, n-i, one, a( i, i+1 ), lda,a( i, i ), 1_${ik}$, zero, t( & 1_${ik}$, n ), 1_${ik}$ ) ! a(i:m,i+1:n) = a(i:m,i+1:n) + alpha*a(i:m,i)*w(1:n-1)^h alpha = -(t( i, 1_${ik}$ )) call stdlib${ii}$_sger( m-i+1, n-i, alpha, a( i, i ), 1_${ik}$,t( 1_${ik}$, n ), 1_${ik}$, a( i, i+1 ), lda & ) a( i, i ) = aii end if end do do i = 2, n aii = a( i, i ) a( i, i ) = one ! t(1:i-1,i) := alpha * a(i:m,1:i-1)**t * a(i:m,i) alpha = -t( i, 1_${ik}$ ) call stdlib${ii}$_sgemv( 'T', m-i+1, i-1, alpha, a( i, 1_${ik}$ ), lda,a( i, i ), 1_${ik}$, zero, t( 1_${ik}$, & i ), 1_${ik}$ ) a( i, i ) = aii ! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i) call stdlib${ii}$_strmv( 'U', 'N', 'N', i-1, t, ldt, t( 1_${ik}$, i ), 1_${ik}$ ) ! t(i,i) = tau(i) t( i, i ) = t( i, 1_${ik}$ ) t( i, 1_${ik}$) = zero end do end subroutine stdlib${ii}$_sgeqrt2 pure module subroutine stdlib${ii}$_dgeqrt2( m, n, a, lda, t, ldt, info ) !! DGEQRT2 computes a QR 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 ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, k real(dp) :: aii, alpha ! Executable Statements ! test the input arguments info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ else if( m<n ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRT2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elem. refl. h(i) to annihilate a(i+1:m,i), tau(i) -> t(i,1) call stdlib${ii}$_dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one ! w(1:n-i) := a(i:m,i+1:n)^h * a(i:m,i) [w = t(:,n)] call stdlib${ii}$_dgemv( 'T',m-i+1, n-i, one, a( i, i+1 ), lda,a( i, i ), 1_${ik}$, zero, t( & 1_${ik}$, n ), 1_${ik}$ ) ! a(i:m,i+1:n) = a(i:m,i+1:n) + alpha*a(i:m,i)*w(1:n-1)^h alpha = -(t( i, 1_${ik}$ )) call stdlib${ii}$_dger( m-i+1, n-i, alpha, a( i, i ), 1_${ik}$,t( 1_${ik}$, n ), 1_${ik}$, a( i, i+1 ), lda & ) a( i, i ) = aii end if end do do i = 2, n aii = a( i, i ) a( i, i ) = one ! t(1:i-1,i) := alpha * a(i:m,1:i-1)**t * a(i:m,i) alpha = -t( i, 1_${ik}$ ) call stdlib${ii}$_dgemv( 'T', m-i+1, i-1, alpha, a( i, 1_${ik}$ ), lda,a( i, i ), 1_${ik}$, zero, t( 1_${ik}$, & i ), 1_${ik}$ ) a( i, i ) = aii ! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i) call stdlib${ii}$_dtrmv( 'U', 'N', 'N', i-1, t, ldt, t( 1_${ik}$, i ), 1_${ik}$ ) ! t(i,i) = tau(i) t( i, i ) = t( i, 1_${ik}$ ) t( i, 1_${ik}$) = zero end do end subroutine stdlib${ii}$_dgeqrt2 #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$geqrt2( m, n, a, lda, t, ldt, info ) !! DGEQRT2: computes a QR 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 ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, k real(${rk}$) :: aii, alpha ! Executable Statements ! test the input arguments info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ else if( m<n ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRT2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elem. refl. h(i) to annihilate a(i+1:m,i), tau(i) -> t(i,1) call stdlib${ii}$_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one ! w(1:n-i) := a(i:m,i+1:n)^h * a(i:m,i) [w = t(:,n)] call stdlib${ii}$_${ri}$gemv( 'T',m-i+1, n-i, one, a( i, i+1 ), lda,a( i, i ), 1_${ik}$, zero, t( & 1_${ik}$, n ), 1_${ik}$ ) ! a(i:m,i+1:n) = a(i:m,i+1:n) + alpha*a(i:m,i)*w(1:n-1)^h alpha = -(t( i, 1_${ik}$ )) call stdlib${ii}$_${ri}$ger( m-i+1, n-i, alpha, a( i, i ), 1_${ik}$,t( 1_${ik}$, n ), 1_${ik}$, a( i, i+1 ), lda & ) a( i, i ) = aii end if end do do i = 2, n aii = a( i, i ) a( i, i ) = one ! t(1:i-1,i) := alpha * a(i:m,1:i-1)**t * a(i:m,i) alpha = -t( i, 1_${ik}$ ) call stdlib${ii}$_${ri}$gemv( 'T', m-i+1, i-1, alpha, a( i, 1_${ik}$ ), lda,a( i, i ), 1_${ik}$, zero, t( 1_${ik}$, & i ), 1_${ik}$ ) a( i, i ) = aii ! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i) call stdlib${ii}$_${ri}$trmv( 'U', 'N', 'N', i-1, t, ldt, t( 1_${ik}$, i ), 1_${ik}$ ) ! t(i,i) = tau(i) t( i, i ) = t( i, 1_${ik}$ ) t( i, 1_${ik}$) = zero end do end subroutine stdlib${ii}$_${ri}$geqrt2 #:endif #:endfor pure module subroutine stdlib${ii}$_cgeqrt2( m, n, a, lda, t, ldt, info ) !! CGEQRT2 computes a QR 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 ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, k complex(sp) :: aii, alpha ! Executable Statements ! test the input arguments info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ else if( m<n ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CGEQRT2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elem. refl. h(i) to annihilate a(i+1:m,i), tau(i) -> t(i,1) call stdlib${ii}$_clarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = cone ! w(1:n-i) := a(i:m,i+1:n)**h * a(i:m,i) [w = t(:,n)] call stdlib${ii}$_cgemv( 'C',m-i+1, n-i, cone, a( i, i+1 ), lda,a( i, i ), 1_${ik}$, czero, t(& 1_${ik}$, n ), 1_${ik}$ ) ! a(i:m,i+1:n) = a(i:m,i+1:n) + alpha*a(i:m,i)*w(1:n-1)**h alpha = -conjg(t( i, 1_${ik}$ )) call stdlib${ii}$_cgerc( m-i+1, n-i, alpha, a( i, i ), 1_${ik}$,t( 1_${ik}$, n ), 1_${ik}$, a( i, i+1 ), & lda ) a( i, i ) = aii end if end do do i = 2, n aii = a( i, i ) a( i, i ) = cone ! t(1:i-1,i) := alpha * a(i:m,1:i-1)**h * a(i:m,i) alpha = -t( i, 1_${ik}$ ) call stdlib${ii}$_cgemv( 'C', m-i+1, i-1, alpha, a( i, 1_${ik}$ ), lda,a( i, i ), 1_${ik}$, czero, t( 1_${ik}$,& i ), 1_${ik}$ ) a( i, i ) = aii ! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i) call stdlib${ii}$_ctrmv( 'U', 'N', 'N', i-1, t, ldt, t( 1_${ik}$, i ), 1_${ik}$ ) ! t(i,i) = tau(i) t( i, i ) = t( i, 1_${ik}$ ) t( i, 1_${ik}$) = czero end do end subroutine stdlib${ii}$_cgeqrt2 pure module subroutine stdlib${ii}$_zgeqrt2( m, n, a, lda, t, ldt, info ) !! ZGEQRT2 computes a QR 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 ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, k complex(dp) :: aii, alpha ! Executable Statements ! test the input arguments info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ else if( m<n ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRT2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elem. refl. h(i) to annihilate a(i+1:m,i), tau(i) -> t(i,1) call stdlib${ii}$_zlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = cone ! w(1:n-i) := a(i:m,i+1:n)^h * a(i:m,i) [w = t(:,n)] call stdlib${ii}$_zgemv( 'C',m-i+1, n-i, cone, a( i, i+1 ), lda,a( i, i ), 1_${ik}$, czero, t(& 1_${ik}$, n ), 1_${ik}$ ) ! a(i:m,i+1:n) = a(i:m,i+1:n) + alpha*a(i:m,i)*w(1:n-1)^h alpha = -conjg(t( i, 1_${ik}$ )) call stdlib${ii}$_zgerc( m-i+1, n-i, alpha, a( i, i ), 1_${ik}$,t( 1_${ik}$, n ), 1_${ik}$, a( i, i+1 ), & lda ) a( i, i ) = aii end if end do do i = 2, n aii = a( i, i ) a( i, i ) = cone ! t(1:i-1,i) := alpha * a(i:m,1:i-1)**h * a(i:m,i) alpha = -t( i, 1_${ik}$ ) call stdlib${ii}$_zgemv( 'C', m-i+1, i-1, alpha, a( i, 1_${ik}$ ), lda,a( i, i ), 1_${ik}$, czero, t( 1_${ik}$,& i ), 1_${ik}$ ) a( i, i ) = aii ! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i) call stdlib${ii}$_ztrmv( 'U', 'N', 'N', i-1, t, ldt, t( 1_${ik}$, i ), 1_${ik}$ ) ! t(i,i) = tau(i) t( i, i ) = t( i, 1_${ik}$ ) t( i, 1_${ik}$) = czero end do end subroutine stdlib${ii}$_zgeqrt2 #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$geqrt2( m, n, a, lda, t, ldt, info ) !! ZGEQRT2: computes a QR 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 ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, k complex(${ck}$) :: aii, alpha ! Executable Statements ! test the input arguments info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ else if( m<n ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRT2', -info ) return end if k = min( m, n ) do i = 1, k ! generate elem. refl. h(i) to annihilate a(i+1:m,i), tau(i) -> t(i,1) call stdlib${ii}$_${ci}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = cone ! w(1:n-i) := a(i:m,i+1:n)^h * a(i:m,i) [w = t(:,n)] call stdlib${ii}$_${ci}$gemv( 'C',m-i+1, n-i, cone, a( i, i+1 ), lda,a( i, i ), 1_${ik}$, czero, t(& 1_${ik}$, n ), 1_${ik}$ ) ! a(i:m,i+1:n) = a(i:m,i+1:n) + alpha*a(i:m,i)*w(1:n-1)^h alpha = -conjg(t( i, 1_${ik}$ )) call stdlib${ii}$_${ci}$gerc( m-i+1, n-i, alpha, a( i, i ), 1_${ik}$,t( 1_${ik}$, n ), 1_${ik}$, a( i, i+1 ), & lda ) a( i, i ) = aii end if end do do i = 2, n aii = a( i, i ) a( i, i ) = cone ! t(1:i-1,i) := alpha * a(i:m,1:i-1)**h * a(i:m,i) alpha = -t( i, 1_${ik}$ ) call stdlib${ii}$_${ci}$gemv( 'C', m-i+1, i-1, alpha, a( i, 1_${ik}$ ), lda,a( i, i ), 1_${ik}$, czero, t( 1_${ik}$,& i ), 1_${ik}$ ) a( i, i ) = aii ! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i) call stdlib${ii}$_${ci}$trmv( 'U', 'N', 'N', i-1, t, ldt, t( 1_${ik}$, i ), 1_${ik}$ ) ! t(i,i) = tau(i) t( i, i ) = t( i, 1_${ik}$ ) t( i, 1_${ik}$) = czero end do end subroutine stdlib${ii}$_${ci}$geqrt2 #:endif #:endfor pure recursive module subroutine stdlib${ii}$_sgeqrt3( m, n, a, lda, t, ldt, info ) !! SGEQRT3 recursively computes a QR 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, n1, n2, iinfo ! Executable Statements info = 0_${ik}$ if( n < 0_${ik}$ ) then info = -2_${ik}$ else if( m < n ) then info = -1_${ik}$ else if( lda < max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt < max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SGEQRT3', -info ) return end if if( n==1_${ik}$ ) then ! compute householder transform when n=1 call stdlib${ii}$_slarfg( m, a(1_${ik}$,1_${ik}$), a( min( 2_${ik}$, m ), 1_${ik}$ ), 1_${ik}$, t(1_${ik}$,1_${ik}$) ) else ! otherwise, split a into blocks... n1 = n/2_${ik}$ n2 = n-n1 j1 = min( n1+1, n ) i1 = min( n+1, m ) ! compute a(1:m,1:n1) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h call stdlib${ii}$_sgeqrt3( m, n1, a, lda, t, ldt, iinfo ) ! compute a(1:m,j1:n) = q1^h a(1:m,j1:n) [workspace: t(1:n1,j1:n)] do j=1,n2 do i=1,n1 t( i, j+n1 ) = a( i, j+n1 ) end do end do call stdlib${ii}$_strmm( 'L', 'L', 'T', 'U', n1, n2, one,a, lda, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_sgemm( 'T', 'N', n1, n2, m-n1, one, a( j1, 1_${ik}$ ), lda,a( j1, j1 ), lda, & one, t( 1_${ik}$, j1 ), ldt) call stdlib${ii}$_strmm( 'L', 'U', 'T', 'N', n1, n2, one,t, ldt, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_sgemm( 'N', 'N', m-n1, n2, n1, -one, a( j1, 1_${ik}$ ), lda,t( 1_${ik}$, j1 ), ldt, & one, a( j1, j1 ), lda ) call stdlib${ii}$_strmm( 'L', 'L', 'N', 'U', n1, n2, one,a, lda, t( 1_${ik}$, j1 ), ldt ) do j=1,n2 do i=1,n1 a( i, j+n1 ) = a( i, j+n1 ) - t( i, j+n1 ) end do end do ! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h call stdlib${ii}$_sgeqrt3( m-n1, n2, a( j1, j1 ), lda,t( j1, j1 ), ldt, iinfo ) ! compute t3 = t(1:n1,j1:n) = -t1 y1^h y2 t2 do i=1,n1 do j=1,n2 t( i, j+n1 ) = (a( j+n1, i )) end do end do call stdlib${ii}$_strmm( 'R', 'L', 'N', 'U', n1, n2, one,a( j1, j1 ), lda, t( 1_${ik}$, j1 ), & ldt ) call stdlib${ii}$_sgemm( 'T', 'N', n1, n2, m-n, one, a( i1, 1_${ik}$ ), lda,a( i1, j1 ), lda, & one, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', n1, n2, -one, t, ldt,t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_strmm( 'R', 'U', 'N', 'N', n1, n2, one,t( j1, j1 ), ldt, t( 1_${ik}$, j1 ), & ldt ) ! y = (y1,y2); r = [ r1 a(1:n1,j1:n) ]; t = [t1 t3] ! [ 0 r2 ] [ 0 t2] end if return end subroutine stdlib${ii}$_sgeqrt3 pure recursive module subroutine stdlib${ii}$_dgeqrt3( m, n, a, lda, t, ldt, info ) !! DGEQRT3 recursively computes a QR 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, n1, n2, iinfo ! Executable Statements info = 0_${ik}$ if( n < 0_${ik}$ ) then info = -2_${ik}$ else if( m < n ) then info = -1_${ik}$ else if( lda < max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt < max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRT3', -info ) return end if if( n==1_${ik}$ ) then ! compute householder transform when n=1 call stdlib${ii}$_dlarfg( m, a(1_${ik}$,1_${ik}$), a( min( 2_${ik}$, m ), 1_${ik}$ ), 1_${ik}$, t(1_${ik}$,1_${ik}$) ) else ! otherwise, split a into blocks... n1 = n/2_${ik}$ n2 = n-n1 j1 = min( n1+1, n ) i1 = min( n+1, m ) ! compute a(1:m,1:n1) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h call stdlib${ii}$_dgeqrt3( m, n1, a, lda, t, ldt, iinfo ) ! compute a(1:m,j1:n) = q1^h a(1:m,j1:n) [workspace: t(1:n1,j1:n)] do j=1,n2 do i=1,n1 t( i, j+n1 ) = a( i, j+n1 ) end do end do call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'U', n1, n2, one,a, lda, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_dgemm( 'T', 'N', n1, n2, m-n1, one, a( j1, 1_${ik}$ ), lda,a( j1, j1 ), lda, & one, t( 1_${ik}$, j1 ), ldt) call stdlib${ii}$_dtrmm( 'L', 'U', 'T', 'N', n1, n2, one,t, ldt, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_dgemm( 'N', 'N', m-n1, n2, n1, -one, a( j1, 1_${ik}$ ), lda,t( 1_${ik}$, j1 ), ldt, & one, a( j1, j1 ), lda ) call stdlib${ii}$_dtrmm( 'L', 'L', 'N', 'U', n1, n2, one,a, lda, t( 1_${ik}$, j1 ), ldt ) do j=1,n2 do i=1,n1 a( i, j+n1 ) = a( i, j+n1 ) - t( i, j+n1 ) end do end do ! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h call stdlib${ii}$_dgeqrt3( m-n1, n2, a( j1, j1 ), lda,t( j1, j1 ), ldt, iinfo ) ! compute t3 = t(1:n1,j1:n) = -t1 y1^h y2 t2 do i=1,n1 do j=1,n2 t( i, j+n1 ) = (a( j+n1, i )) end do end do call stdlib${ii}$_dtrmm( 'R', 'L', 'N', 'U', n1, n2, one,a( j1, j1 ), lda, t( 1_${ik}$, j1 ), & ldt ) call stdlib${ii}$_dgemm( 'T', 'N', n1, n2, m-n, one, a( i1, 1_${ik}$ ), lda,a( i1, j1 ), lda, & one, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', n1, n2, -one, t, ldt,t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_dtrmm( 'R', 'U', 'N', 'N', n1, n2, one,t( j1, j1 ), ldt, t( 1_${ik}$, j1 ), & ldt ) ! y = (y1,y2); r = [ r1 a(1:n1,j1:n) ]; t = [t1 t3] ! [ 0 r2 ] [ 0 t2] end if return end subroutine stdlib${ii}$_dgeqrt3 #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure recursive module subroutine stdlib${ii}$_${ri}$geqrt3( m, n, a, lda, t, ldt, info ) !! DGEQRT3: recursively computes a QR 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, n1, n2, iinfo ! Executable Statements info = 0_${ik}$ if( n < 0_${ik}$ ) then info = -2_${ik}$ else if( m < n ) then info = -1_${ik}$ else if( lda < max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt < max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRT3', -info ) return end if if( n==1_${ik}$ ) then ! compute householder transform when n=1 call stdlib${ii}$_${ri}$larfg( m, a(1_${ik}$,1_${ik}$), a( min( 2_${ik}$, m ), 1_${ik}$ ), 1_${ik}$, t(1_${ik}$,1_${ik}$) ) else ! otherwise, split a into blocks... n1 = n/2_${ik}$ n2 = n-n1 j1 = min( n1+1, n ) i1 = min( n+1, m ) ! compute a(1:m,1:n1) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h call stdlib${ii}$_${ri}$geqrt3( m, n1, a, lda, t, ldt, iinfo ) ! compute a(1:m,j1:n) = q1^h a(1:m,j1:n) [workspace: t(1:n1,j1:n)] do j=1,n2 do i=1,n1 t( i, j+n1 ) = a( i, j+n1 ) end do end do call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'U', n1, n2, one,a, lda, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_${ri}$gemm( 'T', 'N', n1, n2, m-n1, one, a( j1, 1_${ik}$ ), lda,a( j1, j1 ), lda, & one, t( 1_${ik}$, j1 ), ldt) call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'T', 'N', n1, n2, one,t, ldt, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_${ri}$gemm( 'N', 'N', m-n1, n2, n1, -one, a( j1, 1_${ik}$ ), lda,t( 1_${ik}$, j1 ), ldt, & one, a( j1, j1 ), lda ) call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'N', 'U', n1, n2, one,a, lda, t( 1_${ik}$, j1 ), ldt ) do j=1,n2 do i=1,n1 a( i, j+n1 ) = a( i, j+n1 ) - t( i, j+n1 ) end do end do ! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h call stdlib${ii}$_${ri}$geqrt3( m-n1, n2, a( j1, j1 ), lda,t( j1, j1 ), ldt, iinfo ) ! compute t3 = t(1:n1,j1:n) = -t1 y1^h y2 t2 do i=1,n1 do j=1,n2 t( i, j+n1 ) = (a( j+n1, i )) end do end do call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'N', 'U', n1, n2, one,a( j1, j1 ), lda, t( 1_${ik}$, j1 ), & ldt ) call stdlib${ii}$_${ri}$gemm( 'T', 'N', n1, n2, m-n, one, a( i1, 1_${ik}$ ), lda,a( i1, j1 ), lda, & one, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', n1, n2, -one, t, ldt,t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'N', 'N', n1, n2, one,t( j1, j1 ), ldt, t( 1_${ik}$, j1 ), & ldt ) ! y = (y1,y2); r = [ r1 a(1:n1,j1:n) ]; t = [t1 t3] ! [ 0 r2 ] [ 0 t2] end if return end subroutine stdlib${ii}$_${ri}$geqrt3 #:endif #:endfor pure recursive module subroutine stdlib${ii}$_cgeqrt3( m, n, a, lda, t, ldt, info ) !! CGEQRT3 recursively computes a QR 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, n1, n2, iinfo ! Executable Statements info = 0_${ik}$ if( n < 0_${ik}$ ) then info = -2_${ik}$ else if( m < n ) then info = -1_${ik}$ else if( lda < max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt < max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CGEQRT3', -info ) return end if if( n==1_${ik}$ ) then ! compute householder transform when n=1 call stdlib${ii}$_clarfg( m, a(1_${ik}$,1_${ik}$), a( min( 2_${ik}$, m ), 1_${ik}$ ), 1_${ik}$, t(1_${ik}$,1_${ik}$) ) else ! otherwise, split a into blocks... n1 = n/2_${ik}$ n2 = n-n1 j1 = min( n1+1, n ) i1 = min( n+1, m ) ! compute a(1:m,1:n1) <- (y1,r1,t1), where q1 = i - y1 t1 y1**h call stdlib${ii}$_cgeqrt3( m, n1, a, lda, t, ldt, iinfo ) ! compute a(1:m,j1:n) = q1**h a(1:m,j1:n) [workspace: t(1:n1,j1:n)] do j=1,n2 do i=1,n1 t( i, j+n1 ) = a( i, j+n1 ) end do end do call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'U', n1, n2, cone,a, lda, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_cgemm( 'C', 'N', n1, n2, m-n1, cone, a( j1, 1_${ik}$ ), lda,a( j1, j1 ), lda, & cone, t( 1_${ik}$, j1 ), ldt) call stdlib${ii}$_ctrmm( 'L', 'U', 'C', 'N', n1, n2, cone,t, ldt, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_cgemm( 'N', 'N', m-n1, n2, n1, -cone, a( j1, 1_${ik}$ ), lda,t( 1_${ik}$, j1 ), ldt, & cone, a( j1, j1 ), lda ) call stdlib${ii}$_ctrmm( 'L', 'L', 'N', 'U', n1, n2, cone,a, lda, t( 1_${ik}$, j1 ), ldt ) do j=1,n2 do i=1,n1 a( i, j+n1 ) = a( i, j+n1 ) - t( i, j+n1 ) end do end do ! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2**h call stdlib${ii}$_cgeqrt3( m-n1, n2, a( j1, j1 ), lda,t( j1, j1 ), ldt, iinfo ) ! compute t3 = t(1:n1,j1:n) = -t1 y1**h y2 t2 do i=1,n1 do j=1,n2 t( i, j+n1 ) = conjg(a( j+n1, i )) end do end do call stdlib${ii}$_ctrmm( 'R', 'L', 'N', 'U', n1, n2, cone,a( j1, j1 ), lda, t( 1_${ik}$, j1 ), & ldt ) call stdlib${ii}$_cgemm( 'C', 'N', n1, n2, m-n, cone, a( i1, 1_${ik}$ ), lda,a( i1, j1 ), lda, & cone, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', n1, n2, -cone, t, ldt,t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_ctrmm( 'R', 'U', 'N', 'N', n1, n2, cone,t( j1, j1 ), ldt, t( 1_${ik}$, j1 ), & ldt ) ! y = (y1,y2); r = [ r1 a(1:n1,j1:n) ]; t = [t1 t3] ! [ 0 r2 ] [ 0 t2] end if return end subroutine stdlib${ii}$_cgeqrt3 pure recursive module subroutine stdlib${ii}$_zgeqrt3( m, n, a, lda, t, ldt, info ) !! ZGEQRT3 recursively computes a QR 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, n1, n2, iinfo ! Executable Statements info = 0_${ik}$ if( n < 0_${ik}$ ) then info = -2_${ik}$ else if( m < n ) then info = -1_${ik}$ else if( lda < max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt < max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRT3', -info ) return end if if( n==1_${ik}$ ) then ! compute householder transform when n=1 call stdlib${ii}$_zlarfg( m, a(1_${ik}$,1_${ik}$), a( min( 2_${ik}$, m ), 1_${ik}$ ), 1_${ik}$, t(1_${ik}$,1_${ik}$) ) else ! otherwise, split a into blocks... n1 = n/2_${ik}$ n2 = n-n1 j1 = min( n1+1, n ) i1 = min( n+1, m ) ! compute a(1:m,1:n1) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h call stdlib${ii}$_zgeqrt3( m, n1, a, lda, t, ldt, iinfo ) ! compute a(1:m,j1:n) = q1^h a(1:m,j1:n) [workspace: t(1:n1,j1:n)] do j=1,n2 do i=1,n1 t( i, j+n1 ) = a( i, j+n1 ) end do end do call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'U', n1, n2, cone,a, lda, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_zgemm( 'C', 'N', n1, n2, m-n1, cone, a( j1, 1_${ik}$ ), lda,a( j1, j1 ), lda, & cone, t( 1_${ik}$, j1 ), ldt) call stdlib${ii}$_ztrmm( 'L', 'U', 'C', 'N', n1, n2, cone,t, ldt, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_zgemm( 'N', 'N', m-n1, n2, n1, -cone, a( j1, 1_${ik}$ ), lda,t( 1_${ik}$, j1 ), ldt, & cone, a( j1, j1 ), lda ) call stdlib${ii}$_ztrmm( 'L', 'L', 'N', 'U', n1, n2, cone,a, lda, t( 1_${ik}$, j1 ), ldt ) do j=1,n2 do i=1,n1 a( i, j+n1 ) = a( i, j+n1 ) - t( i, j+n1 ) end do end do ! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h call stdlib${ii}$_zgeqrt3( m-n1, n2, a( j1, j1 ), lda,t( j1, j1 ), ldt, iinfo ) ! compute t3 = t(1:n1,j1:n) = -t1 y1^h y2 t2 do i=1,n1 do j=1,n2 t( i, j+n1 ) = conjg(a( j+n1, i )) end do end do call stdlib${ii}$_ztrmm( 'R', 'L', 'N', 'U', n1, n2, cone,a( j1, j1 ), lda, t( 1_${ik}$, j1 ), & ldt ) call stdlib${ii}$_zgemm( 'C', 'N', n1, n2, m-n, cone, a( i1, 1_${ik}$ ), lda,a( i1, j1 ), lda, & cone, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', n1, n2, -cone, t, ldt,t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_ztrmm( 'R', 'U', 'N', 'N', n1, n2, cone,t( j1, j1 ), ldt, t( 1_${ik}$, j1 ), & ldt ) ! y = (y1,y2); r = [ r1 a(1:n1,j1:n) ]; t = [t1 t3] ! [ 0 r2 ] [ 0 t2] end if return end subroutine stdlib${ii}$_zgeqrt3 #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure recursive module subroutine stdlib${ii}$_${ci}$geqrt3( m, n, a, lda, t, ldt, info ) !! ZGEQRT3: recursively computes a QR 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, n1, n2, iinfo ! Executable Statements info = 0_${ik}$ if( n < 0_${ik}$ ) then info = -2_${ik}$ else if( m < n ) then info = -1_${ik}$ else if( lda < max( 1_${ik}$, m ) ) then info = -4_${ik}$ else if( ldt < max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRT3', -info ) return end if if( n==1_${ik}$ ) then ! compute householder transform when n=1 call stdlib${ii}$_${ci}$larfg( m, a(1_${ik}$,1_${ik}$), a( min( 2_${ik}$, m ), 1_${ik}$ ), 1_${ik}$, t(1_${ik}$,1_${ik}$) ) else ! otherwise, split a into blocks... n1 = n/2_${ik}$ n2 = n-n1 j1 = min( n1+1, n ) i1 = min( n+1, m ) ! compute a(1:m,1:n1) <- (y1,r1,t1), where q1 = i - y1 t1 y1^h call stdlib${ii}$_${ci}$geqrt3( m, n1, a, lda, t, ldt, iinfo ) ! compute a(1:m,j1:n) = q1^h a(1:m,j1:n) [workspace: t(1:n1,j1:n)] do j=1,n2 do i=1,n1 t( i, j+n1 ) = a( i, j+n1 ) end do end do call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'U', n1, n2, cone,a, lda, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_${ci}$gemm( 'C', 'N', n1, n2, m-n1, cone, a( j1, 1_${ik}$ ), lda,a( j1, j1 ), lda, & cone, t( 1_${ik}$, j1 ), ldt) call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'C', 'N', n1, n2, cone,t, ldt, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_${ci}$gemm( 'N', 'N', m-n1, n2, n1, -cone, a( j1, 1_${ik}$ ), lda,t( 1_${ik}$, j1 ), ldt, & cone, a( j1, j1 ), lda ) call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', 'U', n1, n2, cone,a, lda, t( 1_${ik}$, j1 ), ldt ) do j=1,n2 do i=1,n1 a( i, j+n1 ) = a( i, j+n1 ) - t( i, j+n1 ) end do end do ! compute a(j1:m,j1:n) <- (y2,r2,t2) where q2 = i - y2 t2 y2^h call stdlib${ii}$_${ci}$geqrt3( m-n1, n2, a( j1, j1 ), lda,t( j1, j1 ), ldt, iinfo ) ! compute t3 = t(1:n1,j1:n) = -t1 y1^h y2 t2 do i=1,n1 do j=1,n2 t( i, j+n1 ) = conjg(a( j+n1, i )) end do end do call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', 'U', n1, n2, cone,a( j1, j1 ), lda, t( 1_${ik}$, j1 ), & ldt ) call stdlib${ii}$_${ci}$gemm( 'C', 'N', n1, n2, m-n, cone, a( i1, 1_${ik}$ ), lda,a( i1, j1 ), lda, & cone, t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', n1, n2, -cone, t, ldt,t( 1_${ik}$, j1 ), ldt ) call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', 'N', n1, n2, cone,t( j1, j1 ), ldt, t( 1_${ik}$, j1 ), & ldt ) ! y = (y1,y2); r = [ r1 a(1:n1,j1:n) ]; t = [t1 t3] ! [ 0 r2 ] [ 0 t2] end if return end subroutine stdlib${ii}$_${ci}$geqrt3 #:endif #:endfor pure module subroutine stdlib${ii}$_sgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! SGEMQRT 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 SGEQRT. !! 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, nb, 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( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$)) then info = -6_${ik}$ else if( ldv<max( 1_${ik}$, q ) ) then info = -8_${ik}$ else if( ldt<nb ) 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( 'SGEMQRT', -info ) return end if ! Quick Return If Possible if( m==0 .or. n==0 .or. k==0 ) return if( left .and. tran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_slarfb( 'L', 'T', 'F', 'C', 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 do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_slarfb( 'R', 'N', 'F', 'C', 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. notran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_slarfb( 'L', 'N', 'F', 'C', 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 kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_slarfb( 'R', 'T', 'F', 'C', 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}$_sgemqrt pure module subroutine stdlib${ii}$_dgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! DGEMQRT 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 DGEQRT. !! 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, nb, 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( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$)) then info = -6_${ik}$ else if( ldv<max( 1_${ik}$, q ) ) then info = -8_${ik}$ else if( ldt<nb ) 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( 'DGEMQRT', -info ) return end if ! Quick Return If Possible if( m==0 .or. n==0 .or. k==0 ) return if( left .and. tran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_dlarfb( 'L', 'T', 'F', 'C', 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 do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_dlarfb( 'R', 'N', 'F', 'C', 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. notran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_dlarfb( 'L', 'N', 'F', 'C', 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 kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_dlarfb( 'R', 'T', 'F', 'C', 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}$_dgemqrt #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$gemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! DGEMQRT: 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 DGEQRT. !! 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, nb, 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( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$)) then info = -6_${ik}$ else if( ldv<max( 1_${ik}$, q ) ) then info = -8_${ik}$ else if( ldt<nb ) 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( 'DGEMQRT', -info ) return end if ! Quick Return If Possible if( m==0 .or. n==0 .or. k==0 ) return if( left .and. tran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_${ri}$larfb( 'L', 'T', 'F', 'C', 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 do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_${ri}$larfb( 'R', 'N', 'F', 'C', 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. notran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_${ri}$larfb( 'L', 'N', 'F', 'C', 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 kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_${ri}$larfb( 'R', 'T', 'F', 'C', 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}$gemqrt #:endif #:endfor pure module subroutine stdlib${ii}$_cgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! CGEMQRT 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 orthogonal 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 CGEQRT. !! 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, nb, 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( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$)) then info = -6_${ik}$ else if( ldv<max( 1_${ik}$, q ) ) then info = -8_${ik}$ else if( ldt<nb ) 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( 'CGEMQRT', -info ) return end if ! Quick Return If Possible if( m==0 .or. n==0 .or. k==0 ) return if( left .and. tran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_clarfb( 'L', 'C', 'F', 'C', 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 do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_clarfb( 'R', 'N', 'F', 'C', 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. notran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_clarfb( 'L', 'N', 'F', 'C', 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 kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_clarfb( 'R', 'C', 'F', 'C', 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}$_cgemqrt pure module subroutine stdlib${ii}$_zgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! ZGEMQRT 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 orthogonal 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 ZGEQRT. !! 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, nb, 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( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$)) then info = -6_${ik}$ else if( ldv<max( 1_${ik}$, q ) ) then info = -8_${ik}$ else if( ldt<nb ) 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( 'ZGEMQRT', -info ) return end if ! Quick Return If Possible if( m==0 .or. n==0 .or. k==0 ) return if( left .and. tran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_zlarfb( 'L', 'C', 'F', 'C', 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 do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_zlarfb( 'R', 'N', 'F', 'C', 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. notran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_zlarfb( 'L', 'N', 'F', 'C', 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 kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_zlarfb( 'R', 'C', 'F', 'C', 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}$_zgemqrt #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$gemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! ZGEMQRT: 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 orthogonal 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 ZGEQRT. !! 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, nb, 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( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$)) then info = -6_${ik}$ else if( ldv<max( 1_${ik}$, q ) ) then info = -8_${ik}$ else if( ldt<nb ) 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( 'ZGEMQRT', -info ) return end if ! Quick Return If Possible if( m==0 .or. n==0 .or. k==0 ) return if( left .and. tran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_${ci}$larfb( 'L', 'C', 'F', 'C', 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 do i = 1, k, nb ib = min( nb, k-i+1 ) call stdlib${ii}$_${ci}$larfb( 'R', 'N', 'F', 'C', 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. notran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_${ci}$larfb( 'L', 'N', 'F', 'C', 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 kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) call stdlib${ii}$_${ci}$larfb( 'R', 'C', 'F', 'C', 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}$gemqrt #:endif #:endfor module subroutine stdlib${ii}$_sgeqrfp( m, n, a, lda, tau, work, lwork, info ) !! SGEQR2P computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix with nonnegative diagonal !! entries; !! 0 is a (M-N)-by-N 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}$, 'SGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = n*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}$, n ) .and. .not.lquery ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SGEQRFP', -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 = 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}$, 'SGEQRF', ' ', 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}$, 'SGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_sgeqr2p( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_slarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_slarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-i-& ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$_sgeqr2p( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_sgeqrfp module subroutine stdlib${ii}$_dgeqrfp( m, n, a, lda, tau, work, lwork, info ) !! DGEQR2P computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix with nonnegative diagonal !! entries; !! 0 is a (M-N)-by-N 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}$, 'DGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = n*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}$, n ) .and. .not.lquery ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRFP', -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 = 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}$, 'DGEQRF', ' ', 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}$, 'DGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_dgeqr2p( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_dlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_dlarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-i-& ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$_dgeqr2p( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_dgeqrfp #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] module subroutine stdlib${ii}$_${ri}$geqrfp( m, n, a, lda, tau, work, lwork, info ) !! DGEQR2P computes a QR factorization of a real M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix with nonnegative diagonal !! entries; !! 0 is a (M-N)-by-N 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}$, 'DGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = n*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}$, n ) .and. .not.lquery ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQRFP', -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 = 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}$, 'DGEQRF', ' ', 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}$, 'DGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_${ri}$geqr2p( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) 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', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**t to a(i:m,i+ib:n) from the left call stdlib${ii}$_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-i-& ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$geqr2p( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_${ri}$geqrfp #:endif #:endfor module subroutine stdlib${ii}$_cgeqrfp( m, n, a, lda, tau, work, lwork, info ) !! CGEQR2P computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix with nonnegative diagonal !! entries; !! 0 is a (M-N)-by-N 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}$, 'CGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = n*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}$, n ) .and. .not.lquery ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CGEQRFP', -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 = 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}$, 'CGEQRF', ' ', 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}$, 'CGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_cgeqr2p( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_clarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_clarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE', m-& i+1, n-i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$_cgeqr2p( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_cgeqrfp module subroutine stdlib${ii}$_zgeqrfp( m, n, a, lda, tau, work, lwork, info ) !! ZGEQR2P computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix with nonnegative diagonal !! entries; !! 0 is a (M-N)-by-N 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}$, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = n*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}$, n ) .and. .not.lquery ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRFP', -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 = 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}$, 'ZGEQRF', ' ', 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}$, 'ZGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_zgeqr2p( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) call stdlib${ii}$_zlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_zlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE', m-& i+1, n-i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$_zgeqr2p( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_zgeqrfp #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] module subroutine stdlib${ii}$_${ci}$geqrfp( m, n, a, lda, tau, work, lwork, info ) !! ZGEQR2P computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix with nonnegative diagonal !! entries; !! 0 is a (M-N)-by-N 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}$, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = n*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}$, n ) .and. .not.lquery ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQRFP', -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 = 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}$, 'ZGEQRF', ' ', 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}$, 'ZGEQRF', ' ', 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 qr factorization of the current block ! a(i:m,i:i+ib-1) call stdlib${ii}$_${ci}$geqr2p( m-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) if( i+ib<=n ) 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', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h**h to a(i:m,i+ib:n) from the left call stdlib${ii}$_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE', m-& i+1, n-i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),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}$geqr2p( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,iinfo ) work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_${ci}$geqrfp #:endif #:endfor module subroutine stdlib${ii}$_sgeqr2p( m, n, a, lda, tau, work, info ) !! SGEQR2P computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix with nonnegative diagonal !! entries; !! 0 is a (m-n)-by-n 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( 'SGEQR2P', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_slarfgp( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one call stdlib${ii}$_slarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) a( i, i ) = aii end if end do return end subroutine stdlib${ii}$_sgeqr2p module subroutine stdlib${ii}$_dgeqr2p( m, n, a, lda, tau, work, info ) !! DGEQR2P computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix with nonnegative diagonal !! entries; !! 0 is a (m-n)-by-n 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( 'DGEQR2P', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_dlarfgp( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one call stdlib${ii}$_dlarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) a( i, i ) = aii end if end do return end subroutine stdlib${ii}$_dgeqr2p #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] module subroutine stdlib${ii}$_${ri}$geqr2p( m, n, a, lda, tau, work, info ) !! DGEQR2P: computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix with nonnegative diagonal !! entries; !! 0 is a (m-n)-by-n 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( 'DGEQR2P', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_${ri}$larfgp( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i) to a(i:m,i+1:n) from the left aii = a( i, i ) a( i, i ) = one call stdlib${ii}$_${ri}$larf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$, tau( i ),a( i, i+1 ), lda, & work ) a( i, i ) = aii end if end do return end subroutine stdlib${ii}$_${ri}$geqr2p #:endif #:endfor module subroutine stdlib${ii}$_cgeqr2p( m, n, a, lda, tau, work, info ) !! CGEQR2P computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix with nonnegative diagonal !! entries; !! 0 is a (m-n)-by-n 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( 'CGEQR2P', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_clarfgp( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i)**h to a(i:m,i+1:n) from the left alpha = a( i, i ) a( i, i ) = cone call stdlib${ii}$_clarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$,conjg( tau( i ) ), a( i, i+1 & ), lda, work ) a( i, i ) = alpha end if end do return end subroutine stdlib${ii}$_cgeqr2p module subroutine stdlib${ii}$_zgeqr2p( m, n, a, lda, tau, work, info ) !! ZGEQR2P computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix with nonnegative diagonal !! entries; !! 0 is a (m-n)-by-n 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( 'ZGEQR2P', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_zlarfgp( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i)**h to a(i:m,i+1:n) from the left alpha = a( i, i ) a( i, i ) = cone call stdlib${ii}$_zlarf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$,conjg( tau( i ) ), a( i, i+1 & ), lda, work ) a( i, i ) = alpha end if end do return end subroutine stdlib${ii}$_zgeqr2p #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] module subroutine stdlib${ii}$_${ci}$geqr2p( m, n, a, lda, tau, work, info ) !! ZGEQR2P: computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a m-by-m orthogonal matrix; !! R is an upper-triangular n-by-n matrix with nonnegative diagonal !! entries; !! 0 is a (m-n)-by-n 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( 'ZGEQR2P', -info ) return end if k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) call stdlib${ii}$_${ci}$larfgp( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tau( i ) ) if( i<n ) then ! apply h(i)**h to a(i:m,i+1:n) from the left alpha = a( i, i ) a( i, i ) = cone call stdlib${ii}$_${ci}$larf( 'LEFT', m-i+1, n-i, a( i, i ), 1_${ik}$,conjg( tau( i ) ), a( i, i+1 & ), lda, work ) a( i, i ) = alpha end if end do return end subroutine stdlib${ii}$_${ci}$geqr2p #:endif #:endfor pure module subroutine stdlib${ii}$_sgeqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) !! SGEQP3 computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: inb = 1_${ik}$ integer(${ik}$), parameter :: inbmin = 2_${ik}$ integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions ! test 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 minmn = min( m, n ) if( minmn==0_${ik}$ ) then iws = 1_${ik}$ lwkopt = 1_${ik}$ else iws = 3_${ik}$*n + 1_${ik}$ nb = stdlib${ii}$_ilaenv( inb, 'SGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = 2_${ik}$*n + ( n + 1_${ik}$ )*nb end if work( 1_${ik}$ ) = lwkopt if( ( lwork<iws ) .and. .not.lquery ) then info = -8_${ik}$ end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SGEQP3', -info ) return else if( lquery ) then return end if ! move initial columns up front. nfxd = 1_${ik}$ do j = 1, n if( jpvt( j )/=0_${ik}$ ) then if( j/=nfxd ) then call stdlib${ii}$_sswap( m, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, nfxd ), 1_${ik}$ ) jpvt( j ) = jpvt( nfxd ) jpvt( nfxd ) = j else jpvt( j ) = j end if nfxd = nfxd + 1_${ik}$ else jpvt( j ) = j end if end do nfxd = nfxd - 1_${ik}$ ! factorize fixed columns ! ======================= ! compute the qr factorization of fixed columns and update ! remaining columns. if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) ! cc call stdlib${ii}$_sgeqr2( m, na, a, lda, tau, work, info ) call stdlib${ii}$_sgeqrf( m, na, a, lda, tau, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na<n ) then ! cc call stdlib${ii}$_sorm2r( 'left', 'transpose', m, n-na, na, a, lda, ! cc $ tau, a( 1, na+1 ), lda, work, info ) call stdlib${ii}$_sormqr( 'LEFT', 'TRANSPOSE', m, n-na, na, a, lda, tau,a( 1_${ik}$, na+1 ), & lda, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) end if end if ! factorize free columns ! ====================== if( nfxd<minmn ) then sm = m - nfxd sn = n - nfxd sminmn = minmn - nfxd ! determine the block size. nb = stdlib${ii}$_ilaenv( inb, 'SGEQRF', ' ', sm, sn, -1_${ik}$, -1_${ik}$ ) nbmin = 2_${ik}$ nx = 0_${ik}$ if( ( nb>1_${ik}$ ) .and. ( nb<sminmn ) ) then ! determine when to cross over from blocked to unblocked code. nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( ixover, 'SGEQRF', ' ', sm, sn, -1_${ik}$,-1_${ik}$ ) ) if( nx<sminmn ) then ! determine if workspace is large enough for blocked code. minws = 2_${ik}$*sn + ( sn+1 )*nb iws = max( iws, minws ) if( lwork<minws ) then ! not enough workspace to use optimal nb: reduce nb and ! determine the minimum value of nb. nb = ( lwork-2*sn ) / ( sn+1 ) nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( inbmin, 'SGEQRF', ' ', sm, sn,-1_${ik}$, -1_${ik}$ ) ) end if end if end if ! initialize partial column norms. the first n elements of work ! store the exact column norms. do j = nfxd + 1, n work( j ) = stdlib${ii}$_snrm2( sm, a( nfxd+1, j ), 1_${ik}$ ) work( n+j ) = work( j ) end do if( ( nb>=nbmin ) .and. ( nb<sminmn ) .and.( nx<sminmn ) ) then ! use blocked code initially. j = nfxd + 1_${ik}$ ! compute factorization: while loop. topbmn = minmn - nx 30 continue if( j<=topbmn ) then jb = min( nb, topbmn-j+1 ) ! factorize jb columns among columns j:n. call stdlib${ii}$_slaqps( m, n-j+1, j-1, jb, fjb, a( 1_${ik}$, j ), lda,jpvt( j ), tau( j )& , work( j ), work( n+j ),work( 2_${ik}$*n+1 ), work( 2_${ik}$*n+jb+1 ), n-j+1 ) j = j + fjb go to 30 end if else j = nfxd + 1_${ik}$ end if ! use unblocked code to factor the last or only block. if( j<=minmn )call stdlib${ii}$_slaqp2( m, n-j+1, j-1, a( 1_${ik}$, j ), lda, jpvt( j ),tau( j ),& work( j ), work( n+j ),work( 2_${ik}$*n+1 ) ) end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_sgeqp3 pure module subroutine stdlib${ii}$_dgeqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) !! DGEQP3 computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: inb = 1_${ik}$ integer(${ik}$), parameter :: inbmin = 2_${ik}$ integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions ! Executable Statements ! test 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 minmn = min( m, n ) if( minmn==0_${ik}$ ) then iws = 1_${ik}$ lwkopt = 1_${ik}$ else iws = 3_${ik}$*n + 1_${ik}$ nb = stdlib${ii}$_ilaenv( inb, 'DGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = 2_${ik}$*n + ( n + 1_${ik}$ )*nb end if work( 1_${ik}$ ) = lwkopt if( ( lwork<iws ) .and. .not.lquery ) then info = -8_${ik}$ end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQP3', -info ) return else if( lquery ) then return end if ! move initial columns up front. nfxd = 1_${ik}$ do j = 1, n if( jpvt( j )/=0_${ik}$ ) then if( j/=nfxd ) then call stdlib${ii}$_dswap( m, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, nfxd ), 1_${ik}$ ) jpvt( j ) = jpvt( nfxd ) jpvt( nfxd ) = j else jpvt( j ) = j end if nfxd = nfxd + 1_${ik}$ else jpvt( j ) = j end if end do nfxd = nfxd - 1_${ik}$ ! factorize fixed columns ! ======================= ! compute the qr factorization of fixed columns and update ! remaining columns. if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) ! cc call stdlib${ii}$_dgeqr2( m, na, a, lda, tau, work, info ) call stdlib${ii}$_dgeqrf( m, na, a, lda, tau, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na<n ) then ! cc call stdlib${ii}$_dorm2r( 'left', 'transpose', m, n-na, na, a, lda, ! cc $ tau, a( 1, na+1 ), lda, work, info ) call stdlib${ii}$_dormqr( 'LEFT', 'TRANSPOSE', m, n-na, na, a, lda, tau,a( 1_${ik}$, na+1 ), & lda, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) end if end if ! factorize free columns ! ====================== if( nfxd<minmn ) then sm = m - nfxd sn = n - nfxd sminmn = minmn - nfxd ! determine the block size. nb = stdlib${ii}$_ilaenv( inb, 'DGEQRF', ' ', sm, sn, -1_${ik}$, -1_${ik}$ ) nbmin = 2_${ik}$ nx = 0_${ik}$ if( ( nb>1_${ik}$ ) .and. ( nb<sminmn ) ) then ! determine when to cross over from blocked to unblocked code. nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( ixover, 'DGEQRF', ' ', sm, sn, -1_${ik}$,-1_${ik}$ ) ) if( nx<sminmn ) then ! determine if workspace is large enough for blocked code. minws = 2_${ik}$*sn + ( sn+1 )*nb iws = max( iws, minws ) if( lwork<minws ) then ! not enough workspace to use optimal nb: reduce nb and ! determine the minimum value of nb. nb = ( lwork-2*sn ) / ( sn+1 ) nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( inbmin, 'DGEQRF', ' ', sm, sn,-1_${ik}$, -1_${ik}$ ) ) end if end if end if ! initialize partial column norms. the first n elements of work ! store the exact column norms. do j = nfxd + 1, n work( j ) = stdlib${ii}$_dnrm2( sm, a( nfxd+1, j ), 1_${ik}$ ) work( n+j ) = work( j ) end do if( ( nb>=nbmin ) .and. ( nb<sminmn ) .and.( nx<sminmn ) ) then ! use blocked code initially. j = nfxd + 1_${ik}$ ! compute factorization: while loop. topbmn = minmn - nx 30 continue if( j<=topbmn ) then jb = min( nb, topbmn-j+1 ) ! factorize jb columns among columns j:n. call stdlib${ii}$_dlaqps( m, n-j+1, j-1, jb, fjb, a( 1_${ik}$, j ), lda,jpvt( j ), tau( j )& , work( j ), work( n+j ),work( 2_${ik}$*n+1 ), work( 2_${ik}$*n+jb+1 ), n-j+1 ) j = j + fjb go to 30 end if else j = nfxd + 1_${ik}$ end if ! use unblocked code to factor the last or only block. if( j<=minmn )call stdlib${ii}$_dlaqp2( m, n-j+1, j-1, a( 1_${ik}$, j ), lda, jpvt( j ),tau( j ),& work( j ), work( n+j ),work( 2_${ik}$*n+1 ) ) end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_dgeqp3 #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$geqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) !! DGEQP3: computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: inb = 1_${ik}$ integer(${ik}$), parameter :: inbmin = 2_${ik}$ integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions ! Executable Statements ! test 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 minmn = min( m, n ) if( minmn==0_${ik}$ ) then iws = 1_${ik}$ lwkopt = 1_${ik}$ else iws = 3_${ik}$*n + 1_${ik}$ nb = stdlib${ii}$_ilaenv( inb, 'DGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = 2_${ik}$*n + ( n + 1_${ik}$ )*nb end if work( 1_${ik}$ ) = lwkopt if( ( lwork<iws ) .and. .not.lquery ) then info = -8_${ik}$ end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGEQP3', -info ) return else if( lquery ) then return end if ! move initial columns up front. nfxd = 1_${ik}$ do j = 1, n if( jpvt( j )/=0_${ik}$ ) then if( j/=nfxd ) then call stdlib${ii}$_${ri}$swap( m, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, nfxd ), 1_${ik}$ ) jpvt( j ) = jpvt( nfxd ) jpvt( nfxd ) = j else jpvt( j ) = j end if nfxd = nfxd + 1_${ik}$ else jpvt( j ) = j end if end do nfxd = nfxd - 1_${ik}$ ! factorize fixed columns ! ======================= ! compute the qr factorization of fixed columns and update ! remaining columns. if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) ! cc call stdlib${ii}$_${ri}$geqr2( m, na, a, lda, tau, work, info ) call stdlib${ii}$_${ri}$geqrf( m, na, a, lda, tau, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na<n ) then ! cc call stdlib${ii}$_${ri}$orm2r( 'left', 'transpose', m, n-na, na, a, lda, ! cc $ tau, a( 1, na+1 ), lda, work, info ) call stdlib${ii}$_${ri}$ormqr( 'LEFT', 'TRANSPOSE', m, n-na, na, a, lda, tau,a( 1_${ik}$, na+1 ), & lda, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) end if end if ! factorize free columns ! ====================== if( nfxd<minmn ) then sm = m - nfxd sn = n - nfxd sminmn = minmn - nfxd ! determine the block size. nb = stdlib${ii}$_ilaenv( inb, 'DGEQRF', ' ', sm, sn, -1_${ik}$, -1_${ik}$ ) nbmin = 2_${ik}$ nx = 0_${ik}$ if( ( nb>1_${ik}$ ) .and. ( nb<sminmn ) ) then ! determine when to cross over from blocked to unblocked code. nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( ixover, 'DGEQRF', ' ', sm, sn, -1_${ik}$,-1_${ik}$ ) ) if( nx<sminmn ) then ! determine if workspace is large enough for blocked code. minws = 2_${ik}$*sn + ( sn+1 )*nb iws = max( iws, minws ) if( lwork<minws ) then ! not enough workspace to use optimal nb: reduce nb and ! determine the minimum value of nb. nb = ( lwork-2*sn ) / ( sn+1 ) nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( inbmin, 'DGEQRF', ' ', sm, sn,-1_${ik}$, -1_${ik}$ ) ) end if end if end if ! initialize partial column norms. the first n elements of work ! store the exact column norms. do j = nfxd + 1, n work( j ) = stdlib${ii}$_${ri}$nrm2( sm, a( nfxd+1, j ), 1_${ik}$ ) work( n+j ) = work( j ) end do if( ( nb>=nbmin ) .and. ( nb<sminmn ) .and.( nx<sminmn ) ) then ! use blocked code initially. j = nfxd + 1_${ik}$ ! compute factorization: while loop. topbmn = minmn - nx 30 continue if( j<=topbmn ) then jb = min( nb, topbmn-j+1 ) ! factorize jb columns among columns j:n. call stdlib${ii}$_${ri}$laqps( m, n-j+1, j-1, jb, fjb, a( 1_${ik}$, j ), lda,jpvt( j ), tau( j )& , work( j ), work( n+j ),work( 2_${ik}$*n+1 ), work( 2_${ik}$*n+jb+1 ), n-j+1 ) j = j + fjb go to 30 end if else j = nfxd + 1_${ik}$ end if ! use unblocked code to factor the last or only block. if( j<=minmn )call stdlib${ii}$_${ri}$laqp2( m, n-j+1, j-1, a( 1_${ik}$, j ), lda, jpvt( j ),tau( j ),& work( j ), work( n+j ),work( 2_${ik}$*n+1 ) ) end if work( 1_${ik}$ ) = iws return end subroutine stdlib${ii}$_${ri}$geqp3 #:endif #:endfor pure module subroutine stdlib${ii}$_cgeqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) !! CGEQP3 computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: inb = 1_${ik}$ integer(${ik}$), parameter :: inbmin = 2_${ik}$ integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions ! Executable Statements ! test 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 minmn = min( m, n ) if( minmn==0_${ik}$ ) then iws = 1_${ik}$ lwkopt = 1_${ik}$ else iws = n + 1_${ik}$ nb = stdlib${ii}$_ilaenv( inb, 'CGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = ( n + 1_${ik}$ )*nb end if work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp) if( ( lwork<iws ) .and. .not.lquery ) then info = -8_${ik}$ end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CGEQP3', -info ) return else if( lquery ) then return end if ! move initial columns up front. nfxd = 1_${ik}$ do j = 1, n if( jpvt( j )/=0_${ik}$ ) then if( j/=nfxd ) then call stdlib${ii}$_cswap( m, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, nfxd ), 1_${ik}$ ) jpvt( j ) = jpvt( nfxd ) jpvt( nfxd ) = j else jpvt( j ) = j end if nfxd = nfxd + 1_${ik}$ else jpvt( j ) = j end if end do nfxd = nfxd - 1_${ik}$ ! factorize fixed columns ! ======================= ! compute the qr factorization of fixed columns and update ! remaining columns. if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) ! cc call stdlib${ii}$_cgeqr2( m, na, a, lda, tau, work, info ) call stdlib${ii}$_cgeqrf( m, na, a, lda, tau, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na<n ) then ! cc call stdlib${ii}$_cunm2r( 'left', 'conjugate transpose', m, n-na, ! cc $ na, a, lda, tau, a( 1, na+1 ), lda, work, ! cc $ info ) call stdlib${ii}$_cunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, n-na, na, a,lda, tau, a( 1_${ik}$,& na+1 ), lda, work, lwork,info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) end if end if ! factorize free columns ! ====================== if( nfxd<minmn ) then sm = m - nfxd sn = n - nfxd sminmn = minmn - nfxd ! determine the block size. nb = stdlib${ii}$_ilaenv( inb, 'CGEQRF', ' ', sm, sn, -1_${ik}$, -1_${ik}$ ) nbmin = 2_${ik}$ nx = 0_${ik}$ if( ( nb>1_${ik}$ ) .and. ( nb<sminmn ) ) then ! determine when to cross over from blocked to unblocked code. nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( ixover, 'CGEQRF', ' ', sm, sn, -1_${ik}$,-1_${ik}$ ) ) if( nx<sminmn ) then ! determine if workspace is large enough for blocked code. minws = ( sn+1 )*nb iws = max( iws, minws ) if( lwork<minws ) then ! not enough workspace to use optimal nb: reduce nb and ! determine the minimum value of nb. nb = lwork / ( sn+1 ) nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( inbmin, 'CGEQRF', ' ', sm, sn,-1_${ik}$, -1_${ik}$ ) ) end if end if end if ! initialize partial column norms. the first n elements of work ! store the exact column norms. do j = nfxd + 1, n rwork( j ) = stdlib${ii}$_scnrm2( sm, a( nfxd+1, j ), 1_${ik}$ ) rwork( n+j ) = rwork( j ) end do if( ( nb>=nbmin ) .and. ( nb<sminmn ) .and.( nx<sminmn ) ) then ! use blocked code initially. j = nfxd + 1_${ik}$ ! compute factorization: while loop. topbmn = minmn - nx 30 continue if( j<=topbmn ) then jb = min( nb, topbmn-j+1 ) ! factorize jb columns among columns j:n. call stdlib${ii}$_claqps( m, n-j+1, j-1, jb, fjb, a( 1_${ik}$, j ), lda,jpvt( j ), tau( j )& , rwork( j ),rwork( n+j ), work( 1_${ik}$ ), work( jb+1 ),n-j+1 ) j = j + fjb go to 30 end if else j = nfxd + 1_${ik}$ end if ! use unblocked code to factor the last or only block. if( j<=minmn )call stdlib${ii}$_claqp2( m, n-j+1, j-1, a( 1_${ik}$, j ), lda, jpvt( j ),tau( j ),& rwork( j ), rwork( n+j ), work( 1_${ik}$ ) ) end if work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp) return end subroutine stdlib${ii}$_cgeqp3 pure module subroutine stdlib${ii}$_zgeqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) !! ZGEQP3 computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: inb = 1_${ik}$ integer(${ik}$), parameter :: inbmin = 2_${ik}$ integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions ! Executable Statements ! test 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 minmn = min( m, n ) if( minmn==0_${ik}$ ) then iws = 1_${ik}$ lwkopt = 1_${ik}$ else iws = n + 1_${ik}$ nb = stdlib${ii}$_ilaenv( inb, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = ( n + 1_${ik}$ )*nb end if work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp) if( ( lwork<iws ) .and. .not.lquery ) then info = -8_${ik}$ end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQP3', -info ) return else if( lquery ) then return end if ! move initial columns up front. nfxd = 1_${ik}$ do j = 1, n if( jpvt( j )/=0_${ik}$ ) then if( j/=nfxd ) then call stdlib${ii}$_zswap( m, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, nfxd ), 1_${ik}$ ) jpvt( j ) = jpvt( nfxd ) jpvt( nfxd ) = j else jpvt( j ) = j end if nfxd = nfxd + 1_${ik}$ else jpvt( j ) = j end if end do nfxd = nfxd - 1_${ik}$ ! factorize fixed columns ! ======================= ! compute the qr factorization of fixed columns and update ! remaining columns. if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) ! cc call stdlib${ii}$_zgeqr2( m, na, a, lda, tau, work, info ) call stdlib${ii}$_zgeqrf( m, na, a, lda, tau, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na<n ) then ! cc call stdlib${ii}$_zunm2r( 'left', 'conjugate transpose', m, n-na, ! cc $ na, a, lda, tau, a( 1, na+1 ), lda, work, ! cc $ info ) call stdlib${ii}$_zunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, n-na, na, a,lda, tau, a( 1_${ik}$,& na+1 ), lda, work, lwork,info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) end if end if ! factorize free columns ! ====================== if( nfxd<minmn ) then sm = m - nfxd sn = n - nfxd sminmn = minmn - nfxd ! determine the block size. nb = stdlib${ii}$_ilaenv( inb, 'ZGEQRF', ' ', sm, sn, -1_${ik}$, -1_${ik}$ ) nbmin = 2_${ik}$ nx = 0_${ik}$ if( ( nb>1_${ik}$ ) .and. ( nb<sminmn ) ) then ! determine when to cross over from blocked to unblocked code. nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( ixover, 'ZGEQRF', ' ', sm, sn, -1_${ik}$,-1_${ik}$ ) ) if( nx<sminmn ) then ! determine if workspace is large enough for blocked code. minws = ( sn+1 )*nb iws = max( iws, minws ) if( lwork<minws ) then ! not enough workspace to use optimal nb: reduce nb and ! determine the minimum value of nb. nb = lwork / ( sn+1 ) nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( inbmin, 'ZGEQRF', ' ', sm, sn,-1_${ik}$, -1_${ik}$ ) ) end if end if end if ! initialize partial column norms. the first n elements of work ! store the exact column norms. do j = nfxd + 1, n rwork( j ) = stdlib${ii}$_dznrm2( sm, a( nfxd+1, j ), 1_${ik}$ ) rwork( n+j ) = rwork( j ) end do if( ( nb>=nbmin ) .and. ( nb<sminmn ) .and.( nx<sminmn ) ) then ! use blocked code initially. j = nfxd + 1_${ik}$ ! compute factorization: while loop. topbmn = minmn - nx 30 continue if( j<=topbmn ) then jb = min( nb, topbmn-j+1 ) ! factorize jb columns among columns j:n. call stdlib${ii}$_zlaqps( m, n-j+1, j-1, jb, fjb, a( 1_${ik}$, j ), lda,jpvt( j ), tau( j )& , rwork( j ),rwork( n+j ), work( 1_${ik}$ ), work( jb+1 ),n-j+1 ) j = j + fjb go to 30 end if else j = nfxd + 1_${ik}$ end if ! use unblocked code to factor the last or only block. if( j<=minmn )call stdlib${ii}$_zlaqp2( m, n-j+1, j-1, a( 1_${ik}$, j ), lda, jpvt( j ),tau( j ),& rwork( j ), rwork( n+j ), work( 1_${ik}$ ) ) end if work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp) return end subroutine stdlib${ii}$_zgeqp3 #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$geqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) !! ZGEQP3: computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: inb = 1_${ik}$ integer(${ik}$), parameter :: inbmin = 2_${ik}$ integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions ! Executable Statements ! test 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 minmn = min( m, n ) if( minmn==0_${ik}$ ) then iws = 1_${ik}$ lwkopt = 1_${ik}$ else iws = n + 1_${ik}$ nb = stdlib${ii}$_ilaenv( inb, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) lwkopt = ( n + 1_${ik}$ )*nb end if work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$) if( ( lwork<iws ) .and. .not.lquery ) then info = -8_${ik}$ end if end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZGEQP3', -info ) return else if( lquery ) then return end if ! move initial columns up front. nfxd = 1_${ik}$ do j = 1, n if( jpvt( j )/=0_${ik}$ ) then if( j/=nfxd ) then call stdlib${ii}$_${ci}$swap( m, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, nfxd ), 1_${ik}$ ) jpvt( j ) = jpvt( nfxd ) jpvt( nfxd ) = j else jpvt( j ) = j end if nfxd = nfxd + 1_${ik}$ else jpvt( j ) = j end if end do nfxd = nfxd - 1_${ik}$ ! factorize fixed columns ! ======================= ! compute the qr factorization of fixed columns and update ! remaining columns. if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) ! cc call stdlib${ii}$_${ci}$geqr2( m, na, a, lda, tau, work, info ) call stdlib${ii}$_${ci}$geqrf( m, na, a, lda, tau, work, lwork, info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na<n ) then ! cc call stdlib${ii}$_${ci}$unm2r( 'left', 'conjugate transpose', m, n-na, ! cc $ na, a, lda, tau, a( 1, na+1 ), lda, work, ! cc $ info ) call stdlib${ii}$_${ci}$unmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, n-na, na, a,lda, tau, a( 1_${ik}$,& na+1 ), lda, work, lwork,info ) iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) end if end if ! factorize free columns ! ====================== if( nfxd<minmn ) then sm = m - nfxd sn = n - nfxd sminmn = minmn - nfxd ! determine the block size. nb = stdlib${ii}$_ilaenv( inb, 'ZGEQRF', ' ', sm, sn, -1_${ik}$, -1_${ik}$ ) nbmin = 2_${ik}$ nx = 0_${ik}$ if( ( nb>1_${ik}$ ) .and. ( nb<sminmn ) ) then ! determine when to cross over from blocked to unblocked code. nx = max( 0_${ik}$, stdlib${ii}$_ilaenv( ixover, 'ZGEQRF', ' ', sm, sn, -1_${ik}$,-1_${ik}$ ) ) if( nx<sminmn ) then ! determine if workspace is large enough for blocked code. minws = ( sn+1 )*nb iws = max( iws, minws ) if( lwork<minws ) then ! not enough workspace to use optimal nb: reduce nb and ! determine the minimum value of nb. nb = lwork / ( sn+1 ) nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( inbmin, 'ZGEQRF', ' ', sm, sn,-1_${ik}$, -1_${ik}$ ) ) end if end if end if ! initialize partial column norms. the first n elements of work ! store the exact column norms. do j = nfxd + 1, n rwork( j ) = stdlib${ii}$_${c2ri(ci)}$znrm2( sm, a( nfxd+1, j ), 1_${ik}$ ) rwork( n+j ) = rwork( j ) end do if( ( nb>=nbmin ) .and. ( nb<sminmn ) .and.( nx<sminmn ) ) then ! use blocked code initially. j = nfxd + 1_${ik}$ ! compute factorization: while loop. topbmn = minmn - nx 30 continue if( j<=topbmn ) then jb = min( nb, topbmn-j+1 ) ! factorize jb columns among columns j:n. call stdlib${ii}$_${ci}$laqps( m, n-j+1, j-1, jb, fjb, a( 1_${ik}$, j ), lda,jpvt( j ), tau( j )& , rwork( j ),rwork( n+j ), work( 1_${ik}$ ), work( jb+1 ),n-j+1 ) j = j + fjb go to 30 end if else j = nfxd + 1_${ik}$ end if ! use unblocked code to factor the last or only block. if( j<=minmn )call stdlib${ii}$_${ci}$laqp2( m, n-j+1, j-1, a( 1_${ik}$, j ), lda, jpvt( j ),tau( j ),& rwork( j ), rwork( n+j ), work( 1_${ik}$ ) ) end if work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$) return end subroutine stdlib${ii}$_${ci}$geqp3 #:endif #:endfor pure module subroutine stdlib${ii}$_slaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! SLAQP2 computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: a(lda,*), vn1(*), vn2(*) real(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(sp) :: aii, temp, temp2, tol3z ! Intrinsic Functions ! Executable Statements mn = min( m-offset, n ) tol3z = sqrt(stdlib${ii}$_slamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. pvt = ( i-1 ) + stdlib${ii}$_isamax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then call stdlib${ii}$_sswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp vn1( pvt ) = vn1( i ) vn2( pvt ) = vn2( i ) end if ! generate elementary reflector h(i). if( offpi<m ) then call stdlib${ii}$_slarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1_${ik}$,tau( i ) ) else call stdlib${ii}$_slarfg( 1_${ik}$, a( m, i ), a( m, i ), 1_${ik}$, tau( i ) ) end if if( i<n ) then ! apply h(i)**t to a(offset+i:m,i+1:n) from the left. aii = a( offpi, i ) a( offpi, i ) = one call stdlib${ii}$_slarf( 'LEFT', m-offpi+1, n-i, a( offpi, i ), 1_${ik}$,tau( i ), a( offpi, & i+1 ), lda, work( 1_${ik}$ ) ) a( offpi, i ) = aii end if ! update partial column norms. do j = i + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = one - ( abs( a( offpi, j ) ) / vn1( j ) )**2_${ik}$ temp = max( temp, zero ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then if( offpi<m ) then vn1( j ) = stdlib${ii}$_snrm2( m-offpi, a( offpi+1, j ), 1_${ik}$ ) vn2( j ) = vn1( j ) else vn1( j ) = zero vn2( j ) = zero end if else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end do loop_20 return end subroutine stdlib${ii}$_slaqp2 pure module subroutine stdlib${ii}$_dlaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! DLAQP2 computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: a(lda,*), vn1(*), vn2(*) real(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(dp) :: aii, temp, temp2, tol3z ! Intrinsic Functions ! Executable Statements mn = min( m-offset, n ) tol3z = sqrt(stdlib${ii}$_dlamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. pvt = ( i-1 ) + stdlib${ii}$_idamax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then call stdlib${ii}$_dswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp vn1( pvt ) = vn1( i ) vn2( pvt ) = vn2( i ) end if ! generate elementary reflector h(i). if( offpi<m ) then call stdlib${ii}$_dlarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1_${ik}$,tau( i ) ) else call stdlib${ii}$_dlarfg( 1_${ik}$, a( m, i ), a( m, i ), 1_${ik}$, tau( i ) ) end if if( i<n ) then ! apply h(i)**t to a(offset+i:m,i+1:n) from the left. aii = a( offpi, i ) a( offpi, i ) = one call stdlib${ii}$_dlarf( 'LEFT', m-offpi+1, n-i, a( offpi, i ), 1_${ik}$,tau( i ), a( offpi, & i+1 ), lda, work( 1_${ik}$ ) ) a( offpi, i ) = aii end if ! update partial column norms. do j = i + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = one - ( abs( a( offpi, j ) ) / vn1( j ) )**2_${ik}$ temp = max( temp, zero ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then if( offpi<m ) then vn1( j ) = stdlib${ii}$_dnrm2( m-offpi, a( offpi+1, j ), 1_${ik}$ ) vn2( j ) = vn1( j ) else vn1( j ) = zero vn2( j ) = zero end if else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end do loop_20 return end subroutine stdlib${ii}$_dlaqp2 #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$laqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! DLAQP2: computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(${rk}$), intent(inout) :: a(lda,*), vn1(*), vn2(*) real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(${rk}$) :: aii, temp, temp2, tol3z ! Intrinsic Functions ! Executable Statements mn = min( m-offset, n ) tol3z = sqrt(stdlib${ii}$_${ri}$lamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. pvt = ( i-1 ) + stdlib${ii}$_i${ri}$amax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then call stdlib${ii}$_${ri}$swap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp vn1( pvt ) = vn1( i ) vn2( pvt ) = vn2( i ) end if ! generate elementary reflector h(i). if( offpi<m ) then call stdlib${ii}$_${ri}$larfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1_${ik}$,tau( i ) ) else call stdlib${ii}$_${ri}$larfg( 1_${ik}$, a( m, i ), a( m, i ), 1_${ik}$, tau( i ) ) end if if( i<n ) then ! apply h(i)**t to a(offset+i:m,i+1:n) from the left. aii = a( offpi, i ) a( offpi, i ) = one call stdlib${ii}$_${ri}$larf( 'LEFT', m-offpi+1, n-i, a( offpi, i ), 1_${ik}$,tau( i ), a( offpi, & i+1 ), lda, work( 1_${ik}$ ) ) a( offpi, i ) = aii end if ! update partial column norms. do j = i + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = one - ( abs( a( offpi, j ) ) / vn1( j ) )**2_${ik}$ temp = max( temp, zero ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then if( offpi<m ) then vn1( j ) = stdlib${ii}$_${ri}$nrm2( m-offpi, a( offpi+1, j ), 1_${ik}$ ) vn2( j ) = vn1( j ) else vn1( j ) = zero vn2( j ) = zero end if else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end do loop_20 return end subroutine stdlib${ii}$_${ri}$laqp2 #:endif #:endfor pure module subroutine stdlib${ii}$_claqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! CLAQP2 computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: vn1(*), vn2(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(sp) :: temp, temp2, tol3z complex(sp) :: aii ! Intrinsic Functions ! Executable Statements mn = min( m-offset, n ) tol3z = sqrt(stdlib${ii}$_slamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. pvt = ( i-1 ) + stdlib${ii}$_isamax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then call stdlib${ii}$_cswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp vn1( pvt ) = vn1( i ) vn2( pvt ) = vn2( i ) end if ! generate elementary reflector h(i). if( offpi<m ) then call stdlib${ii}$_clarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1_${ik}$,tau( i ) ) else call stdlib${ii}$_clarfg( 1_${ik}$, a( m, i ), a( m, i ), 1_${ik}$, tau( i ) ) end if if( i<n ) then ! apply h(i)**h to a(offset+i:m,i+1:n) from the left. aii = a( offpi, i ) a( offpi, i ) = cone call stdlib${ii}$_clarf( 'LEFT', m-offpi+1, n-i, a( offpi, i ), 1_${ik}$,conjg( tau( i ) ), a(& offpi, i+1 ), lda,work( 1_${ik}$ ) ) a( offpi, i ) = aii end if ! update partial column norms. do j = i + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = one - ( abs( a( offpi, j ) ) / vn1( j ) )**2_${ik}$ temp = max( temp, zero ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then if( offpi<m ) then vn1( j ) = stdlib${ii}$_scnrm2( m-offpi, a( offpi+1, j ), 1_${ik}$ ) vn2( j ) = vn1( j ) else vn1( j ) = zero vn2( j ) = zero end if else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end do loop_20 return end subroutine stdlib${ii}$_claqp2 pure module subroutine stdlib${ii}$_zlaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! ZLAQP2 computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: vn1(*), vn2(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(dp) :: temp, temp2, tol3z complex(dp) :: aii ! Intrinsic Functions ! Executable Statements mn = min( m-offset, n ) tol3z = sqrt(stdlib${ii}$_dlamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. pvt = ( i-1 ) + stdlib${ii}$_idamax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then call stdlib${ii}$_zswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp vn1( pvt ) = vn1( i ) vn2( pvt ) = vn2( i ) end if ! generate elementary reflector h(i). if( offpi<m ) then call stdlib${ii}$_zlarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1_${ik}$,tau( i ) ) else call stdlib${ii}$_zlarfg( 1_${ik}$, a( m, i ), a( m, i ), 1_${ik}$, tau( i ) ) end if if( i<n ) then ! apply h(i)**h to a(offset+i:m,i+1:n) from the left. aii = a( offpi, i ) a( offpi, i ) = cone call stdlib${ii}$_zlarf( 'LEFT', m-offpi+1, n-i, a( offpi, i ), 1_${ik}$,conjg( tau( i ) ), a(& offpi, i+1 ), lda,work( 1_${ik}$ ) ) a( offpi, i ) = aii end if ! update partial column norms. do j = i + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = one - ( abs( a( offpi, j ) ) / vn1( j ) )**2_${ik}$ temp = max( temp, zero ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then if( offpi<m ) then vn1( j ) = stdlib${ii}$_dznrm2( m-offpi, a( offpi+1, j ), 1_${ik}$ ) vn2( j ) = vn1( j ) else vn1( j ) = zero vn2( j ) = zero end if else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end do loop_20 return end subroutine stdlib${ii}$_zlaqp2 #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$laqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! ZLAQP2: computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(${ck}$), intent(inout) :: vn1(*), vn2(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(${ck}$) :: temp, temp2, tol3z complex(${ck}$) :: aii ! Intrinsic Functions ! Executable Statements mn = min( m-offset, n ) tol3z = sqrt(stdlib${ii}$_${c2ri(ci)}$lamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. pvt = ( i-1 ) + stdlib${ii}$_i${c2ri(ci)}$amax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then call stdlib${ii}$_${ci}$swap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp vn1( pvt ) = vn1( i ) vn2( pvt ) = vn2( i ) end if ! generate elementary reflector h(i). if( offpi<m ) then call stdlib${ii}$_${ci}$larfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1_${ik}$,tau( i ) ) else call stdlib${ii}$_${ci}$larfg( 1_${ik}$, a( m, i ), a( m, i ), 1_${ik}$, tau( i ) ) end if if( i<n ) then ! apply h(i)**h to a(offset+i:m,i+1:n) from the left. aii = a( offpi, i ) a( offpi, i ) = cone call stdlib${ii}$_${ci}$larf( 'LEFT', m-offpi+1, n-i, a( offpi, i ), 1_${ik}$,conjg( tau( i ) ), a(& offpi, i+1 ), lda,work( 1_${ik}$ ) ) a( offpi, i ) = aii end if ! update partial column norms. do j = i + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = one - ( abs( a( offpi, j ) ) / vn1( j ) )**2_${ik}$ temp = max( temp, zero ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then if( offpi<m ) then vn1( j ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m-offpi, a( offpi+1, j ), 1_${ik}$ ) vn2( j ) = vn1( j ) else vn1( j ) = zero vn2( j ) = zero end if else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end do loop_20 return end subroutine stdlib${ii}$_${ci}$laqp2 #:endif #:endfor pure module subroutine stdlib${ii}$_slaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & !! SLAQPS computes a step of QR factorization with column pivoting !! of a real M-by-N matrix A by using Blas-3. It tries to factorize !! NB columns from A starting from the row OFFSET+1, and updates all !! of the matrix with Blas-3 xGEMM. !! In some cases, due to catastrophic cancellations, it cannot !! factorize NB columns. Hence, the actual number of factorized !! columns is returned in KB. !! Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ldf ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: kb integer(${ik}$), intent(in) :: lda, ldf, m, n, nb, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: a(lda,*), auxv(*), f(ldf,*), vn1(*), vn2(*) real(sp), intent(out) :: tau(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: itemp, j, k, lastrk, lsticc, pvt, rk real(sp) :: akk, temp, temp2, tol3z ! Intrinsic Functions ! Executable Statements lastrk = min( m, n+offset ) lsticc = 0_${ik}$ k = 0_${ik}$ tol3z = sqrt(stdlib${ii}$_slamch('EPSILON')) ! beginning of while loop. 10 continue if( ( k<nb ) .and. ( lsticc==0_${ik}$ ) ) then k = k + 1_${ik}$ rk = offset + k ! determine ith pivot column and swap if necessary pvt = ( k-1 ) + stdlib${ii}$_isamax( n-k+1, vn1( k ), 1_${ik}$ ) if( pvt/=k ) then call stdlib${ii}$_sswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) call stdlib${ii}$_sswap( k-1, f( pvt, 1_${ik}$ ), ldf, f( k, 1_${ik}$ ), ldf ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( k ) jpvt( k ) = itemp vn1( pvt ) = vn1( k ) vn2( pvt ) = vn2( k ) end if ! apply previous householder reflectors to column k: ! a(rk:m,k) := a(rk:m,k) - a(rk:m,1:k-1)*f(k,1:k-1)**t. if( k>1_${ik}$ ) then call stdlib${ii}$_sgemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ), & ldf, one, a( rk, k ), 1_${ik}$ ) end if ! generate elementary reflector h(k). if( rk<m ) then call stdlib${ii}$_slarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1_${ik}$, tau( k ) ) else call stdlib${ii}$_slarfg( 1_${ik}$, a( rk, k ), a( rk, k ), 1_${ik}$, tau( k ) ) end if akk = a( rk, k ) a( rk, k ) = one ! compute kth column of f: ! compute f(k+1:n,k) := tau(k)*a(rk:m,k+1:n)**t*a(rk:m,k). if( k<n ) then call stdlib${ii}$_sgemv( 'TRANSPOSE', m-rk+1, n-k, tau( k ),a( rk, k+1 ), lda, a( rk, & k ), 1_${ik}$, zero,f( k+1, k ), 1_${ik}$ ) end if ! padding f(1:k,k) with zeros. do j = 1, k f( j, k ) = zero end do ! incremental updating of f: ! f(1:n,k) := f(1:n,k) - tau(k)*f(1:n,1:k-1)*a(rk:m,1:k-1)**t ! *a(rk:m,k). if( k>1_${ik}$ ) then call stdlib${ii}$_sgemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1_${ik}$ ),lda, a( rk, k & ), 1_${ik}$, zero, auxv( 1_${ik}$ ), 1_${ik}$ ) call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n, k-1, one, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, one,& f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**t. if( k<n ) then call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k, k, -one, f( k+1, 1_${ik}$ ), ldf,a( rk, 1_${ik}$ ), & lda, one, a( rk, k+1 ), lda ) end if ! update partial column norms. if( rk<lastrk ) then do j = k + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = abs( a( rk, j ) ) / vn1( j ) temp = max( zero, ( one+temp )*( one-temp ) ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then vn2( j ) = real( lsticc,KIND=sp) lsticc = j else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end if a( rk, k ) = akk ! end of while loop. go to 10 end if kb = k rk = offset + kb ! apply the block reflector to the rest of the matrix: ! a(offset+kb+1:m,kb+1:n) := a(offset+kb+1:m,kb+1:n) - ! a(offset+kb+1:m,1:kb)*f(kb+1:n,1:kb)**t. if( kb<min( n, m-offset ) ) then call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-rk, n-kb, kb, -one,a( rk+1, 1_${ik}$ ), & lda, f( kb+1, 1_${ik}$ ), ldf, one,a( rk+1, kb+1 ), lda ) end if ! recomputation of difficult columns. 40 continue if( lsticc>0_${ik}$ ) then itemp = nint( vn2( lsticc ),KIND=${ik}$) vn1( lsticc ) = stdlib${ii}$_snrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that ! stdlib${ii}$_snrm2 does not fail on vectors with norm below the value of ! sqrt(stdlib${ii}$_dlamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 40 end if return end subroutine stdlib${ii}$_slaqps pure module subroutine stdlib${ii}$_dlaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & !! DLAQPS computes a step of QR factorization with column pivoting !! of a real M-by-N matrix A by using Blas-3. It tries to factorize !! NB columns from A starting from the row OFFSET+1, and updates all !! of the matrix with Blas-3 xGEMM. !! In some cases, due to catastrophic cancellations, it cannot !! factorize NB columns. Hence, the actual number of factorized !! columns is returned in KB. !! Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ldf ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: kb integer(${ik}$), intent(in) :: lda, ldf, m, n, nb, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: a(lda,*), auxv(*), f(ldf,*), vn1(*), vn2(*) real(dp), intent(out) :: tau(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: itemp, j, k, lastrk, lsticc, pvt, rk real(dp) :: akk, temp, temp2, tol3z ! Intrinsic Functions ! Executable Statements lastrk = min( m, n+offset ) lsticc = 0_${ik}$ k = 0_${ik}$ tol3z = sqrt(stdlib${ii}$_dlamch('EPSILON')) ! beginning of while loop. 10 continue if( ( k<nb ) .and. ( lsticc==0_${ik}$ ) ) then k = k + 1_${ik}$ rk = offset + k ! determine ith pivot column and swap if necessary pvt = ( k-1 ) + stdlib${ii}$_idamax( n-k+1, vn1( k ), 1_${ik}$ ) if( pvt/=k ) then call stdlib${ii}$_dswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) call stdlib${ii}$_dswap( k-1, f( pvt, 1_${ik}$ ), ldf, f( k, 1_${ik}$ ), ldf ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( k ) jpvt( k ) = itemp vn1( pvt ) = vn1( k ) vn2( pvt ) = vn2( k ) end if ! apply previous householder reflectors to column k: ! a(rk:m,k) := a(rk:m,k) - a(rk:m,1:k-1)*f(k,1:k-1)**t. if( k>1_${ik}$ ) then call stdlib${ii}$_dgemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ), & ldf, one, a( rk, k ), 1_${ik}$ ) end if ! generate elementary reflector h(k). if( rk<m ) then call stdlib${ii}$_dlarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1_${ik}$, tau( k ) ) else call stdlib${ii}$_dlarfg( 1_${ik}$, a( rk, k ), a( rk, k ), 1_${ik}$, tau( k ) ) end if akk = a( rk, k ) a( rk, k ) = one ! compute kth column of f: ! compute f(k+1:n,k) := tau(k)*a(rk:m,k+1:n)**t*a(rk:m,k). if( k<n ) then call stdlib${ii}$_dgemv( 'TRANSPOSE', m-rk+1, n-k, tau( k ),a( rk, k+1 ), lda, a( rk, & k ), 1_${ik}$, zero,f( k+1, k ), 1_${ik}$ ) end if ! padding f(1:k,k) with zeros. do j = 1, k f( j, k ) = zero end do ! incremental updating of f: ! f(1:n,k) := f(1:n,k) - tau(k)*f(1:n,1:k-1)*a(rk:m,1:k-1)**t ! *a(rk:m,k). if( k>1_${ik}$ ) then call stdlib${ii}$_dgemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1_${ik}$ ),lda, a( rk, k & ), 1_${ik}$, zero, auxv( 1_${ik}$ ), 1_${ik}$ ) call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n, k-1, one, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, one,& f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**t. if( k<n ) then call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k, k, -one, f( k+1, 1_${ik}$ ), ldf,a( rk, 1_${ik}$ ), & lda, one, a( rk, k+1 ), lda ) end if ! update partial column norms. if( rk<lastrk ) then do j = k + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = abs( a( rk, j ) ) / vn1( j ) temp = max( zero, ( one+temp )*( one-temp ) ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then vn2( j ) = real( lsticc,KIND=dp) lsticc = j else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end if a( rk, k ) = akk ! end of while loop. go to 10 end if kb = k rk = offset + kb ! apply the block reflector to the rest of the matrix: ! a(offset+kb+1:m,kb+1:n) := a(offset+kb+1:m,kb+1:n) - ! a(offset+kb+1:m,1:kb)*f(kb+1:n,1:kb)**t. if( kb<min( n, m-offset ) ) then call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-rk, n-kb, kb, -one,a( rk+1, 1_${ik}$ ), & lda, f( kb+1, 1_${ik}$ ), ldf, one,a( rk+1, kb+1 ), lda ) end if ! recomputation of difficult columns. 40 continue if( lsticc>0_${ik}$ ) then itemp = nint( vn2( lsticc ),KIND=${ik}$) vn1( lsticc ) = stdlib${ii}$_dnrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that ! stdlib${ii}$_snrm2 does not fail on vectors with norm below the value of ! sqrt(stdlib${ii}$_dlamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 40 end if return end subroutine stdlib${ii}$_dlaqps #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$laqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & !! DLAQPS: computes a step of QR factorization with column pivoting !! of a real M-by-N matrix A by using Blas-3. It tries to factorize !! NB columns from A starting from the row OFFSET+1, and updates all !! of the matrix with Blas-3 xGEMM. !! In some cases, due to catastrophic cancellations, it cannot !! factorize NB columns. Hence, the actual number of factorized !! columns is returned in KB. !! Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ldf ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: kb integer(${ik}$), intent(in) :: lda, ldf, m, n, nb, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(${rk}$), intent(inout) :: a(lda,*), auxv(*), f(ldf,*), vn1(*), vn2(*) real(${rk}$), intent(out) :: tau(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: itemp, j, k, lastrk, lsticc, pvt, rk real(${rk}$) :: akk, temp, temp2, tol3z ! Intrinsic Functions ! Executable Statements lastrk = min( m, n+offset ) lsticc = 0_${ik}$ k = 0_${ik}$ tol3z = sqrt(stdlib${ii}$_${ri}$lamch('EPSILON')) ! beginning of while loop. 10 continue if( ( k<nb ) .and. ( lsticc==0_${ik}$ ) ) then k = k + 1_${ik}$ rk = offset + k ! determine ith pivot column and swap if necessary pvt = ( k-1 ) + stdlib${ii}$_i${ri}$amax( n-k+1, vn1( k ), 1_${ik}$ ) if( pvt/=k ) then call stdlib${ii}$_${ri}$swap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) call stdlib${ii}$_${ri}$swap( k-1, f( pvt, 1_${ik}$ ), ldf, f( k, 1_${ik}$ ), ldf ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( k ) jpvt( k ) = itemp vn1( pvt ) = vn1( k ) vn2( pvt ) = vn2( k ) end if ! apply previous householder reflectors to column k: ! a(rk:m,k) := a(rk:m,k) - a(rk:m,1:k-1)*f(k,1:k-1)**t. if( k>1_${ik}$ ) then call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ), & ldf, one, a( rk, k ), 1_${ik}$ ) end if ! generate elementary reflector h(k). if( rk<m ) then call stdlib${ii}$_${ri}$larfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1_${ik}$, tau( k ) ) else call stdlib${ii}$_${ri}$larfg( 1_${ik}$, a( rk, k ), a( rk, k ), 1_${ik}$, tau( k ) ) end if akk = a( rk, k ) a( rk, k ) = one ! compute kth column of f: ! compute f(k+1:n,k) := tau(k)*a(rk:m,k+1:n)**t*a(rk:m,k). if( k<n ) then call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', m-rk+1, n-k, tau( k ),a( rk, k+1 ), lda, a( rk, & k ), 1_${ik}$, zero,f( k+1, k ), 1_${ik}$ ) end if ! padding f(1:k,k) with zeros. do j = 1, k f( j, k ) = zero end do ! incremental updating of f: ! f(1:n,k) := f(1:n,k) - tau(k)*f(1:n,1:k-1)*a(rk:m,1:k-1)**t ! *a(rk:m,k). if( k>1_${ik}$ ) then call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1_${ik}$ ),lda, a( rk, k & ), 1_${ik}$, zero, auxv( 1_${ik}$ ), 1_${ik}$ ) call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n, k-1, one, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, one,& f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**t. if( k<n ) then call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k, k, -one, f( k+1, 1_${ik}$ ), ldf,a( rk, 1_${ik}$ ), & lda, one, a( rk, k+1 ), lda ) end if ! update partial column norms. if( rk<lastrk ) then do j = k + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = abs( a( rk, j ) ) / vn1( j ) temp = max( zero, ( one+temp )*( one-temp ) ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then vn2( j ) = real( lsticc,KIND=${rk}$) lsticc = j else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end if a( rk, k ) = akk ! end of while loop. go to 10 end if kb = k rk = offset + kb ! apply the block reflector to the rest of the matrix: ! a(offset+kb+1:m,kb+1:n) := a(offset+kb+1:m,kb+1:n) - ! a(offset+kb+1:m,1:kb)*f(kb+1:n,1:kb)**t. if( kb<min( n, m-offset ) ) then call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-rk, n-kb, kb, -one,a( rk+1, 1_${ik}$ ), & lda, f( kb+1, 1_${ik}$ ), ldf, one,a( rk+1, kb+1 ), lda ) end if ! recomputation of difficult columns. 40 continue if( lsticc>0_${ik}$ ) then itemp = nint( vn2( lsticc ),KIND=${ik}$) vn1( lsticc ) = stdlib${ii}$_${ri}$nrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that ! stdlib${ii}$_dnrm2 does not fail on vectors with norm below the value of ! sqrt(stdlib${ii}$_${ri}$lamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 40 end if return end subroutine stdlib${ii}$_${ri}$laqps #:endif #:endfor pure module subroutine stdlib${ii}$_claqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & !! CLAQPS computes a step of QR factorization with column pivoting !! of a complex M-by-N matrix A by using Blas-3. It tries to factorize !! NB columns from A starting from the row OFFSET+1, and updates all !! of the matrix with Blas-3 xGEMM. !! In some cases, due to catastrophic cancellations, it cannot !! factorize NB columns. Hence, the actual number of factorized !! columns is returned in KB. !! Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ldf ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: kb integer(${ik}$), intent(in) :: lda, ldf, m, n, nb, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: vn1(*), vn2(*) complex(sp), intent(inout) :: a(lda,*), auxv(*), f(ldf,*) complex(sp), intent(out) :: tau(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: itemp, j, k, lastrk, lsticc, pvt, rk real(sp) :: temp, temp2, tol3z complex(sp) :: akk ! Intrinsic Functions ! Executable Statements lastrk = min( m, n+offset ) lsticc = 0_${ik}$ k = 0_${ik}$ tol3z = sqrt(stdlib${ii}$_slamch('EPSILON')) ! beginning of while loop. 10 continue if( ( k<nb ) .and. ( lsticc==0_${ik}$ ) ) then k = k + 1_${ik}$ rk = offset + k ! determine ith pivot column and swap if necessary pvt = ( k-1 ) + stdlib${ii}$_isamax( n-k+1, vn1( k ), 1_${ik}$ ) if( pvt/=k ) then call stdlib${ii}$_cswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) call stdlib${ii}$_cswap( k-1, f( pvt, 1_${ik}$ ), ldf, f( k, 1_${ik}$ ), ldf ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( k ) jpvt( k ) = itemp vn1( pvt ) = vn1( k ) vn2( pvt ) = vn2( k ) end if ! apply previous householder reflectors to column k: ! a(rk:m,k) := a(rk:m,k) - a(rk:m,1:k-1)*f(k,1:k-1)**h. if( k>1_${ik}$ ) then do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do call stdlib${ii}$_cgemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ),& ldf, cone, a( rk, k ), 1_${ik}$ ) do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do end if ! generate elementary reflector h(k). if( rk<m ) then call stdlib${ii}$_clarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1_${ik}$, tau( k ) ) else call stdlib${ii}$_clarfg( 1_${ik}$, a( rk, k ), a( rk, k ), 1_${ik}$, tau( k ) ) end if akk = a( rk, k ) a( rk, k ) = cone ! compute kth column of f: ! compute f(k+1:n,k) := tau(k)*a(rk:m,k+1:n)**h*a(rk:m,k). if( k<n ) then call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', m-rk+1, n-k, tau( k ),a( rk, k+1 ), & lda, a( rk, k ), 1_${ik}$, czero,f( k+1, k ), 1_${ik}$ ) end if ! padding f(1:k,k) with zeros. do j = 1, k f( j, k ) = czero end do ! incremental updating of f: ! f(1:n,k) := f(1:n,k) - tau(k)*f(1:n,1:k-1)*a(rk:m,1:k-1)**h ! *a(rk:m,k). if( k>1_${ik}$ ) then call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1_${ik}$ ), lda,& a( rk, k ), 1_${ik}$, czero,auxv( 1_${ik}$ ), 1_${ik}$ ) call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n, k-1, cone, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, & cone, f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**h. if( k<n ) then call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', 1_${ik}$, n-k,k, -cone, a( rk,& 1_${ik}$ ), lda, f( k+1, 1_${ik}$ ), ldf,cone, a( rk, k+1 ), lda ) end if ! update partial column norms. if( rk<lastrk ) then do j = k + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = abs( a( rk, j ) ) / vn1( j ) temp = max( zero, ( one+temp )*( one-temp ) ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then vn2( j ) = real( lsticc,KIND=sp) lsticc = j else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end if a( rk, k ) = akk ! end of while loop. go to 10 end if kb = k rk = offset + kb ! apply the block reflector to the rest of the matrix: ! a(offset+kb+1:m,kb+1:n) := a(offset+kb+1:m,kb+1:n) - ! a(offset+kb+1:m,1:kb)*f(kb+1:n,1:kb)**h. if( kb<min( n, m-offset ) ) then call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-rk, n-kb,kb, -cone, a( & rk+1, 1_${ik}$ ), lda, f( kb+1, 1_${ik}$ ), ldf,cone, a( rk+1, kb+1 ), lda ) end if ! recomputation of difficult columns. 60 continue if( lsticc>0_${ik}$ ) then itemp = nint( vn2( lsticc ),KIND=${ik}$) vn1( lsticc ) = stdlib${ii}$_scnrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that ! stdlib${ii}$_snrm2 does not fail on vectors with norm below the value of ! sqrt(stdlib${ii}$_dlamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 60 end if return end subroutine stdlib${ii}$_claqps pure module subroutine stdlib${ii}$_zlaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & !! ZLAQPS computes a step of QR factorization with column pivoting !! of a complex M-by-N matrix A by using Blas-3. It tries to factorize !! NB columns from A starting from the row OFFSET+1, and updates all !! of the matrix with Blas-3 xGEMM. !! In some cases, due to catastrophic cancellations, it cannot !! factorize NB columns. Hence, the actual number of factorized !! columns is returned in KB. !! Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ldf ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: kb integer(${ik}$), intent(in) :: lda, ldf, m, n, nb, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: vn1(*), vn2(*) complex(dp), intent(inout) :: a(lda,*), auxv(*), f(ldf,*) complex(dp), intent(out) :: tau(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: itemp, j, k, lastrk, lsticc, pvt, rk real(dp) :: temp, temp2, tol3z complex(dp) :: akk ! Intrinsic Functions ! Executable Statements lastrk = min( m, n+offset ) lsticc = 0_${ik}$ k = 0_${ik}$ tol3z = sqrt(stdlib${ii}$_dlamch('EPSILON')) ! beginning of while loop. 10 continue if( ( k<nb ) .and. ( lsticc==0_${ik}$ ) ) then k = k + 1_${ik}$ rk = offset + k ! determine ith pivot column and swap if necessary pvt = ( k-1 ) + stdlib${ii}$_idamax( n-k+1, vn1( k ), 1_${ik}$ ) if( pvt/=k ) then call stdlib${ii}$_zswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) call stdlib${ii}$_zswap( k-1, f( pvt, 1_${ik}$ ), ldf, f( k, 1_${ik}$ ), ldf ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( k ) jpvt( k ) = itemp vn1( pvt ) = vn1( k ) vn2( pvt ) = vn2( k ) end if ! apply previous householder reflectors to column k: ! a(rk:m,k) := a(rk:m,k) - a(rk:m,1:k-1)*f(k,1:k-1)**h. if( k>1_${ik}$ ) then do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do call stdlib${ii}$_zgemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ),& ldf, cone, a( rk, k ), 1_${ik}$ ) do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do end if ! generate elementary reflector h(k). if( rk<m ) then call stdlib${ii}$_zlarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1_${ik}$, tau( k ) ) else call stdlib${ii}$_zlarfg( 1_${ik}$, a( rk, k ), a( rk, k ), 1_${ik}$, tau( k ) ) end if akk = a( rk, k ) a( rk, k ) = cone ! compute kth column of f: ! compute f(k+1:n,k) := tau(k)*a(rk:m,k+1:n)**h*a(rk:m,k). if( k<n ) then call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', m-rk+1, n-k, tau( k ),a( rk, k+1 ), & lda, a( rk, k ), 1_${ik}$, czero,f( k+1, k ), 1_${ik}$ ) end if ! padding f(1:k,k) with zeros. do j = 1, k f( j, k ) = czero end do ! incremental updating of f: ! f(1:n,k) := f(1:n,k) - tau(k)*f(1:n,1:k-1)*a(rk:m,1:k-1)**h ! *a(rk:m,k). if( k>1_${ik}$ ) then call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1_${ik}$ ), lda,& a( rk, k ), 1_${ik}$, czero,auxv( 1_${ik}$ ), 1_${ik}$ ) call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n, k-1, cone, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, & cone, f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**h. if( k<n ) then call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', 1_${ik}$, n-k,k, -cone, a( rk,& 1_${ik}$ ), lda, f( k+1, 1_${ik}$ ), ldf,cone, a( rk, k+1 ), lda ) end if ! update partial column norms. if( rk<lastrk ) then do j = k + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = abs( a( rk, j ) ) / vn1( j ) temp = max( zero, ( one+temp )*( one-temp ) ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then vn2( j ) = real( lsticc,KIND=dp) lsticc = j else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end if a( rk, k ) = akk ! end of while loop. go to 10 end if kb = k rk = offset + kb ! apply the block reflector to the rest of the matrix: ! a(offset+kb+1:m,kb+1:n) := a(offset+kb+1:m,kb+1:n) - ! a(offset+kb+1:m,1:kb)*f(kb+1:n,1:kb)**h. if( kb<min( n, m-offset ) ) then call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-rk, n-kb,kb, -cone, a( & rk+1, 1_${ik}$ ), lda, f( kb+1, 1_${ik}$ ), ldf,cone, a( rk+1, kb+1 ), lda ) end if ! recomputation of difficult columns. 60 continue if( lsticc>0_${ik}$ ) then itemp = nint( vn2( lsticc ),KIND=${ik}$) vn1( lsticc ) = stdlib${ii}$_dznrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that ! stdlib${ii}$_snrm2 does not fail on vectors with norm below the value of ! sqrt(stdlib${ii}$_dlamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 60 end if return end subroutine stdlib${ii}$_zlaqps #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$laqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & !! ZLAQPS: computes a step of QR factorization with column pivoting !! of a complex M-by-N matrix A by using Blas-3. It tries to factorize !! NB columns from A starting from the row OFFSET+1, and updates all !! of the matrix with Blas-3 xGEMM. !! In some cases, due to catastrophic cancellations, it cannot !! factorize NB columns. Hence, the actual number of factorized !! columns is returned in KB. !! Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ldf ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments integer(${ik}$), intent(out) :: kb integer(${ik}$), intent(in) :: lda, ldf, m, n, nb, offset ! Array Arguments integer(${ik}$), intent(inout) :: jpvt(*) real(${ck}$), intent(inout) :: vn1(*), vn2(*) complex(${ck}$), intent(inout) :: a(lda,*), auxv(*), f(ldf,*) complex(${ck}$), intent(out) :: tau(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: itemp, j, k, lastrk, lsticc, pvt, rk real(${ck}$) :: temp, temp2, tol3z complex(${ck}$) :: akk ! Intrinsic Functions ! Executable Statements lastrk = min( m, n+offset ) lsticc = 0_${ik}$ k = 0_${ik}$ tol3z = sqrt(stdlib${ii}$_${c2ri(ci)}$lamch('EPSILON')) ! beginning of while loop. 10 continue if( ( k<nb ) .and. ( lsticc==0_${ik}$ ) ) then k = k + 1_${ik}$ rk = offset + k ! determine ith pivot column and swap if necessary pvt = ( k-1 ) + stdlib${ii}$_i${c2ri(ci)}$amax( n-k+1, vn1( k ), 1_${ik}$ ) if( pvt/=k ) then call stdlib${ii}$_${ci}$swap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) call stdlib${ii}$_${ci}$swap( k-1, f( pvt, 1_${ik}$ ), ldf, f( k, 1_${ik}$ ), ldf ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( k ) jpvt( k ) = itemp vn1( pvt ) = vn1( k ) vn2( pvt ) = vn2( k ) end if ! apply previous householder reflectors to column k: ! a(rk:m,k) := a(rk:m,k) - a(rk:m,1:k-1)*f(k,1:k-1)**h. if( k>1_${ik}$ ) then do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ),& ldf, cone, a( rk, k ), 1_${ik}$ ) do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do end if ! generate elementary reflector h(k). if( rk<m ) then call stdlib${ii}$_${ci}$larfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1_${ik}$, tau( k ) ) else call stdlib${ii}$_${ci}$larfg( 1_${ik}$, a( rk, k ), a( rk, k ), 1_${ik}$, tau( k ) ) end if akk = a( rk, k ) a( rk, k ) = cone ! compute kth column of f: ! compute f(k+1:n,k) := tau(k)*a(rk:m,k+1:n)**h*a(rk:m,k). if( k<n ) then call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', m-rk+1, n-k, tau( k ),a( rk, k+1 ), & lda, a( rk, k ), 1_${ik}$, czero,f( k+1, k ), 1_${ik}$ ) end if ! padding f(1:k,k) with zeros. do j = 1, k f( j, k ) = czero end do ! incremental updating of f: ! f(1:n,k) := f(1:n,k) - tau(k)*f(1:n,1:k-1)*a(rk:m,1:k-1)**h ! *a(rk:m,k). if( k>1_${ik}$ ) then call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1_${ik}$ ), lda,& a( rk, k ), 1_${ik}$, czero,auxv( 1_${ik}$ ), 1_${ik}$ ) call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n, k-1, cone, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, & cone, f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**h. if( k<n ) then call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', 1_${ik}$, n-k,k, -cone, a( rk,& 1_${ik}$ ), lda, f( k+1, 1_${ik}$ ), ldf,cone, a( rk, k+1 ), lda ) end if ! update partial column norms. if( rk<lastrk ) then do j = k + 1, n if( vn1( j )/=zero ) then ! note: the following 4 lines follow from the analysis in ! lapack working note 176. temp = abs( a( rk, j ) ) / vn1( j ) temp = max( zero, ( one+temp )*( one-temp ) ) temp2 = temp*( vn1( j ) / vn2( j ) )**2_${ik}$ if( temp2 <= tol3z ) then vn2( j ) = real( lsticc,KIND=${ck}$) lsticc = j else vn1( j ) = vn1( j )*sqrt( temp ) end if end if end do end if a( rk, k ) = akk ! end of while loop. go to 10 end if kb = k rk = offset + kb ! apply the block reflector to the rest of the matrix: ! a(offset+kb+1:m,kb+1:n) := a(offset+kb+1:m,kb+1:n) - ! a(offset+kb+1:m,1:kb)*f(kb+1:n,1:kb)**h. if( kb<min( n, m-offset ) ) then call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-rk, n-kb,kb, -cone, a( & rk+1, 1_${ik}$ ), lda, f( kb+1, 1_${ik}$ ), ldf,cone, a( rk+1, kb+1 ), lda ) end if ! recomputation of difficult columns. 60 continue if( lsticc>0_${ik}$ ) then itemp = nint( vn2( lsticc ),KIND=${ik}$) vn1( lsticc ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that ! stdlib${ii}$_dnrm2 does not fail on vectors with norm below the value of ! sqrt(stdlib${ii}$_${c2ri(ci)}$lamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 60 end if return end subroutine stdlib${ii}$_${ci}$laqps #:endif #:endfor pure module subroutine stdlib${ii}$_slatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! SLATSQR computes a blocked Tall-Skinny QR factorization of !! a real M-by-N matrix A for M >= N: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix, stored on exit in an implicit !! form in the elements below the diagonal of the array A and in !! the elements of the array T; !! R is an upper-triangular N-by-N matrix, stored on exit in !! the elements on and above the diagonal of the array A. !! 0 is a (M-N)-by-N zero matrix, 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, ldt, lwork ! 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. m<n ) then info = -2_${ik}$ else if( mb<1_${ik}$ ) then info = -3_${ik}$ else if( nb<1_${ik}$ .or. ( nb>n .and. n>0_${ik}$ )) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<nb ) then info = -8_${ik}$ else if( lwork<(n*nb) .and. (.not.lquery) ) then info = -10_${ik}$ end if if( info==0_${ik}$) then work(1_${ik}$) = nb*n end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SLATSQR', -info ) return else if (lquery) then return end if ! quick return if possible if( min(m,n)==0_${ik}$ ) then return end if ! the qr decomposition if ((mb<=n).or.(mb>=m)) then call stdlib${ii}$_sgeqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) call stdlib${ii}$_sgeqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) call stdlib${ii}$_stpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then call stdlib${ii}$_stpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$), & ldt,work, info ) end if work( 1_${ik}$ ) = n*nb return end subroutine stdlib${ii}$_slatsqr pure module subroutine stdlib${ii}$_dlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! DLATSQR computes a blocked Tall-Skinny QR factorization of !! a real M-by-N matrix A for M >= N: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix, stored on exit in an implicit !! form in the elements below the diagonal of the array A and in !! the elements of the array T; !! R is an upper-triangular N-by-N matrix, stored on exit in !! the elements on and above the diagonal of the array A. !! 0 is a (M-N)-by-N zero matrix, 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, ldt, lwork ! 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. m<n ) then info = -2_${ik}$ else if( mb<1_${ik}$ ) then info = -3_${ik}$ else if( nb<1_${ik}$ .or. ( nb>n .and. n>0_${ik}$ )) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<nb ) then info = -8_${ik}$ else if( lwork<(n*nb) .and. (.not.lquery) ) then info = -10_${ik}$ end if if( info==0_${ik}$) then work(1_${ik}$) = nb*n end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DLATSQR', -info ) return else if (lquery) then return end if ! quick return if possible if( min(m,n)==0_${ik}$ ) then return end if ! the qr decomposition if ((mb<=n).or.(mb>=m)) then call stdlib${ii}$_dgeqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) call stdlib${ii}$_dgeqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) call stdlib${ii}$_dtpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then call stdlib${ii}$_dtpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$), & ldt,work, info ) end if work( 1_${ik}$ ) = n*nb return end subroutine stdlib${ii}$_dlatsqr #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$latsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! DLATSQR: computes a blocked Tall-Skinny QR factorization of !! a real M-by-N matrix A for M >= N: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix, stored on exit in an implicit !! form in the elements below the diagonal of the array A and in !! the elements of the array T; !! R is an upper-triangular N-by-N matrix, stored on exit in !! the elements on and above the diagonal of the array A. !! 0 is a (M-N)-by-N zero matrix, 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, ldt, lwork ! 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. m<n ) then info = -2_${ik}$ else if( mb<1_${ik}$ ) then info = -3_${ik}$ else if( nb<1_${ik}$ .or. ( nb>n .and. n>0_${ik}$ )) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<nb ) then info = -8_${ik}$ else if( lwork<(n*nb) .and. (.not.lquery) ) then info = -10_${ik}$ end if if( info==0_${ik}$) then work(1_${ik}$) = nb*n end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DLATSQR', -info ) return else if (lquery) then return end if ! quick return if possible if( min(m,n)==0_${ik}$ ) then return end if ! the qr decomposition if ((mb<=n).or.(mb>=m)) then call stdlib${ii}$_${ri}$geqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) call stdlib${ii}$_${ri}$geqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) call stdlib${ii}$_${ri}$tpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then call stdlib${ii}$_${ri}$tpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$), & ldt,work, info ) end if work( 1_${ik}$ ) = n*nb return end subroutine stdlib${ii}$_${ri}$latsqr #:endif #:endfor pure module subroutine stdlib${ii}$_clatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! CLATSQR computes a blocked Tall-Skinny QR factorization of !! a complex M-by-N matrix A for M >= N: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix, stored on exit in an implicit !! form in the elements below the diagonal of the array A and in !! the elements of the array T; !! R is an upper-triangular N-by-N matrix, stored on exit in !! the elements on and above the diagonal of the array A. !! 0 is a (M-N)-by-N zero matrix, 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, ldt, lwork ! 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. m<n ) then info = -2_${ik}$ else if( mb<1_${ik}$ ) then info = -3_${ik}$ else if( nb<1_${ik}$ .or. ( nb>n .and. n>0_${ik}$ )) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<nb ) then info = -8_${ik}$ else if( lwork<(n*nb) .and. (.not.lquery) ) then info = -10_${ik}$ end if if( info==0_${ik}$) then work(1_${ik}$) = nb*n end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CLATSQR', -info ) return else if (lquery) then return end if ! quick return if possible if( min(m,n)==0_${ik}$ ) then return end if ! the qr decomposition if ((mb<=n).or.(mb>=m)) then call stdlib${ii}$_cgeqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) call stdlib${ii}$_cgeqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) call stdlib${ii}$_ctpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$,ctr * n + 1_${ik}$),& ldt, work, info ) ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then call stdlib${ii}$_ctpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$), & ldt,work, info ) end if work( 1_${ik}$ ) = n*nb return end subroutine stdlib${ii}$_clatsqr pure module subroutine stdlib${ii}$_zlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! ZLATSQR computes a blocked Tall-Skinny QR factorization of !! a complex M-by-N matrix A for M >= N: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix, stored on exit in an implicit !! form in the elements below the diagonal of the array A and in !! the elements of the array T; !! R is an upper-triangular N-by-N matrix, stored on exit in !! the elements on and above the diagonal of the array A. !! 0 is a (M-N)-by-N zero matrix, 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, ldt, lwork ! 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. m<n ) then info = -2_${ik}$ else if( mb<1_${ik}$ ) then info = -3_${ik}$ else if( nb<1_${ik}$ .or. ( nb>n .and. n>0_${ik}$ )) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<nb ) then info = -8_${ik}$ else if( lwork<(n*nb) .and. (.not.lquery) ) then info = -10_${ik}$ end if if( info==0_${ik}$) then work(1_${ik}$) = nb*n end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZLATSQR', -info ) return else if (lquery) then return end if ! quick return if possible if( min(m,n)==0_${ik}$ ) then return end if ! the qr decomposition if ((mb<=n).or.(mb>=m)) then call stdlib${ii}$_zgeqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) call stdlib${ii}$_zgeqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) call stdlib${ii}$_ztpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then call stdlib${ii}$_ztpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$,ctr * n + 1_${ik}$), & ldt,work, info ) end if work( 1_${ik}$ ) = n*nb return end subroutine stdlib${ii}$_zlatsqr #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$latsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! ZLATSQR: computes a blocked Tall-Skinny QR factorization of !! a complex M-by-N matrix A for M >= N: !! A = Q * ( R ), !! ( 0 ) !! where: !! Q is a M-by-M orthogonal matrix, stored on exit in an implicit !! form in the elements below the diagonal of the array A and in !! the elements of the array T; !! R is an upper-triangular N-by-N matrix, stored on exit in !! the elements on and above the diagonal of the array A. !! 0 is a (M-N)-by-N zero matrix, 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, ldt, lwork ! 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. m<n ) then info = -2_${ik}$ else if( mb<1_${ik}$ ) then info = -3_${ik}$ else if( nb<1_${ik}$ .or. ( nb>n .and. n>0_${ik}$ )) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<nb ) then info = -8_${ik}$ else if( lwork<(n*nb) .and. (.not.lquery) ) then info = -10_${ik}$ end if if( info==0_${ik}$) then work(1_${ik}$) = nb*n end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZLATSQR', -info ) return else if (lquery) then return end if ! quick return if possible if( min(m,n)==0_${ik}$ ) then return end if ! the qr decomposition if ((mb<=n).or.(mb>=m)) then call stdlib${ii}$_${ci}$geqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) call stdlib${ii}$_${ci}$geqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) call stdlib${ii}$_${ci}$tpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then call stdlib${ii}$_${ci}$tpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$,ctr * n + 1_${ik}$), & ldt,work, info ) end if work( 1_${ik}$ ) = n*nb return end subroutine stdlib${ii}$_${ci}$latsqr #:endif #:endfor pure module subroutine stdlib${ii}$_cungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! CUNGTSQR generates an M-by-N complex matrix Q_out with orthonormal !! columns, which are the first N columns of a product of comlpex unitary !! matrices of order M which are returned by CLATSQR !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! See the documentation for CLATSQR. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: t(ldt,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions ! Executable Statements ! test the input parameters lquery = lwork==-1_${ik}$ info = 0_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array c(ldc, n) and work(lwork) ! in the call to stdlib${ii}$_clamtsqr. see the documentation for stdlib${ii}$_clamtsqr. if( lwork<2_${ik}$ .and. (.not.lquery) ) then info = -10_${ik}$ else ! set block size for column blocks nblocal = min( nb, n ) ! lwork = -1, then set the size for the array c(ldc,n) ! in stdlib${ii}$_clamtsqr call and set the optimal size of the work array ! work(lwork) in stdlib${ii}$_clamtsqr call. ldc = m lc = ldc*n lw = n * nblocal lworkopt = lc+lw if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -10_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CUNGTSQR', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=sp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=sp) return end if ! (1) form explicitly the tall-skinny m-by-n left submatrix q1_in ! of m-by-m orthogonal matrix q_in, which is implicitly stored in ! the subdiagonal part of input array a and in the input array t. ! perform by the following operation using the routine stdlib${ii}$_clamtsqr. ! q1_in = q_in * ( i ), where i is a n-by-n identity matrix, ! ( 0 ) 0 is a (m-n)-by-n zero matrix. ! (1a) form m-by-n matrix in the array work(1:ldc*n) with ones ! on the diagonal and zeros elsewhere. call stdlib${ii}$_claset( 'F', m, n, czero, cone, work, ldc ) ! (1b) on input, work(1:ldc*n) stores ( i ); ! ( 0 ) ! on output, work(1:ldc*n) stores q1_in. call stdlib${ii}$_clamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & lc+1 ), lw, iinfo ) ! (2) copy the result from the part of the work array (1:m,1:n) ! with the leading dimension ldc that starts at work(1) into ! the output array a(1:m,1:n) column-by-column. do j = 1, n call stdlib${ii}$_ccopy( m, work( (j-1)*ldc + 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) end do work( 1_${ik}$ ) = cmplx( lworkopt,KIND=sp) return end subroutine stdlib${ii}$_cungtsqr pure module subroutine stdlib${ii}$_zungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! ZUNGTSQR generates an M-by-N complex matrix Q_out with orthonormal !! columns, which are the first N columns of a product of comlpex unitary !! matrices of order M which are returned by ZLATSQR !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! See the documentation for ZLATSQR. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: t(ldt,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions ! Executable Statements ! test the input parameters lquery = lwork==-1_${ik}$ info = 0_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array c(ldc, n) and work(lwork) ! in the call to stdlib${ii}$_zlamtsqr. see the documentation for stdlib${ii}$_zlamtsqr. if( lwork<2_${ik}$ .and. (.not.lquery) ) then info = -10_${ik}$ else ! set block size for column blocks nblocal = min( nb, n ) ! lwork = -1, then set the size for the array c(ldc,n) ! in stdlib${ii}$_zlamtsqr call and set the optimal size of the work array ! work(lwork) in stdlib${ii}$_zlamtsqr call. ldc = m lc = ldc*n lw = n * nblocal lworkopt = lc+lw if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -10_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZUNGTSQR', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=dp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=dp) return end if ! (1) form explicitly the tall-skinny m-by-n left submatrix q1_in ! of m-by-m orthogonal matrix q_in, which is implicitly stored in ! the subdiagonal part of input array a and in the input array t. ! perform by the following operation using the routine stdlib${ii}$_zlamtsqr. ! q1_in = q_in * ( i ), where i is a n-by-n identity matrix, ! ( 0 ) 0 is a (m-n)-by-n zero matrix. ! (1a) form m-by-n matrix in the array work(1:ldc*n) with ones ! on the diagonal and zeros elsewhere. call stdlib${ii}$_zlaset( 'F', m, n, czero, cone, work, ldc ) ! (1b) on input, work(1:ldc*n) stores ( i ); ! ( 0 ) ! on output, work(1:ldc*n) stores q1_in. call stdlib${ii}$_zlamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & lc+1 ), lw, iinfo ) ! (2) copy the result from the part of the work array (1:m,1:n) ! with the leading dimension ldc that starts at work(1) into ! the output array a(1:m,1:n) column-by-column. do j = 1, n call stdlib${ii}$_zcopy( m, work( (j-1)*ldc + 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) end do work( 1_${ik}$ ) = cmplx( lworkopt,KIND=dp) return end subroutine stdlib${ii}$_zungtsqr #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$ungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! ZUNGTSQR: generates an M-by-N complex matrix Q_out with orthonormal !! columns, which are the first N columns of a product of comlpex unitary !! matrices of order M which are returned by ZLATSQR !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! See the documentation for ZLATSQR. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: t(ldt,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions ! Executable Statements ! test the input parameters lquery = lwork==-1_${ik}$ info = 0_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array c(ldc, n) and work(lwork) ! in the call to stdlib${ii}$_${ci}$lamtsqr. see the documentation for stdlib${ii}$_${ci}$lamtsqr. if( lwork<2_${ik}$ .and. (.not.lquery) ) then info = -10_${ik}$ else ! set block size for column blocks nblocal = min( nb, n ) ! lwork = -1, then set the size for the array c(ldc,n) ! in stdlib${ii}$_${ci}$lamtsqr call and set the optimal size of the work array ! work(lwork) in stdlib${ii}$_${ci}$lamtsqr call. ldc = m lc = ldc*n lw = n * nblocal lworkopt = lc+lw if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -10_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZUNGTSQR', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=${ck}$) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=${ck}$) return end if ! (1) form explicitly the tall-skinny m-by-n left submatrix q1_in ! of m-by-m orthogonal matrix q_in, which is implicitly stored in ! the subdiagonal part of input array a and in the input array t. ! perform by the following operation using the routine stdlib${ii}$_${ci}$lamtsqr. ! q1_in = q_in * ( i ), where i is a n-by-n identity matrix, ! ( 0 ) 0 is a (m-n)-by-n zero matrix. ! (1a) form m-by-n matrix in the array work(1:ldc*n) with ones ! on the diagonal and zeros elsewhere. call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, cone, work, ldc ) ! (1b) on input, work(1:ldc*n) stores ( i ); ! ( 0 ) ! on output, work(1:ldc*n) stores q1_in. call stdlib${ii}$_${ci}$lamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & lc+1 ), lw, iinfo ) ! (2) copy the result from the part of the work array (1:m,1:n) ! with the leading dimension ldc that starts at work(1) into ! the output array a(1:m,1:n) column-by-column. do j = 1, n call stdlib${ii}$_${ci}$copy( m, work( (j-1)*ldc + 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) end do work( 1_${ik}$ ) = cmplx( lworkopt,KIND=${ck}$) return end subroutine stdlib${ii}$_${ci}$ungtsqr #:endif #:endfor pure module subroutine stdlib${ii}$_cungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! CUNGTSQR_ROW generates an M-by-N complex matrix Q_out with !! orthonormal columns from the output of CLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary !! matrices Q(k)_in of order M, which are returned by CLATSQR in !! a special format. !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! The input matrices Q(k)_in are stored in row and column blocks in A. !! See the documentation of CLATSQR for more details on the format of !! Q(k)_in, where each Q(k)_in is represented by block Householder !! transformations. This routine calls an auxiliary routine CLARFB_GETT, !! where the computation is performed on each individual block. The !! algorithm first sweeps NB-sized column blocks from the right to left !! starting in the bottom row block and continues to the top row block !! (hence _ROW in the routine name). This sweep is in reverse order of !! the order in which CLATSQR generates the output blocks. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: t(ldt,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & num_all_row_blocks, jb_t, ib, imb, kb, kb_last, knb, mb1 ! Local Arrays complex(sp) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ lquery = lwork==-1_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else if( lwork<1_${ik}$ .and. .not.lquery ) then info = -10_${ik}$ end if nblocal = min( nb, n ) ! determine the workspace size. if( info==0_${ik}$ ) then lworkopt = nblocal * max( nblocal, ( n - nblocal ) ) end if ! handle error in the input parameters and handle the workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CUNGTSQR_ROW', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=sp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=sp) return end if ! (0) set the upper-triangular part of the matrix a to zero and ! its diagonal elements to one. call stdlib${ii}$_claset('U', m, n, czero, cone, a, lda ) ! kb_last is the column index of the last column block reflector ! in the matrices t and v. kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1_${ik}$ ! (1) bottom-up loop over row blocks of a, except the top row block. ! note: if mb>=m, then the loop is never executed. if ( mb<m ) then ! mb2 is the row blocking size for the row blocks before the ! first top row block in the matrix a. ib is the row index for ! the row blocks in the matrix a before the first top row block. ! ib_bottom is the row index for the last bottom row block ! in the matrix a. jb_t is the column index of the corresponding ! column block in the matrix t. ! initialize variables. ! num_all_row_blocks is the number of row blocks in the matrix a ! including the first row block. mb2 = mb - n m_plus_one = m + 1_${ik}$ itmp = ( m - mb - 1_${ik}$ ) / mb2 ib_bottom = itmp * mb2 + mb + 1_${ik}$ num_all_row_blocks = itmp + 2_${ik}$ jb_t = num_all_row_blocks * n + 1_${ik}$ do ib = ib_bottom, mb+1, -mb2 ! determine the block size imb for the current row block ! in the matrix a. imb = min( m_plus_one - ib, mb2 ) ! determine the column index jb_t for the current column block ! in the matrix t. jb_t = jb_t - n ! apply column blocks of h in the row block from right to left. ! kb is the column index of the current column block reflector ! in the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) call stdlib${ii}$_clarfb_gett( 'I', imb, n-kb+1, knb,t( 1_${ik}$, jb_t+kb-1 ), ldt, a( kb, & kb ), lda,a( ib, kb ), lda, work, knb ) end do end do end if ! (2) top row block of a. ! note: if mb>=m, then we have only one row block of a of size m ! and we work on the entire matrix a. mb1 = min( mb, m ) ! apply column blocks of h in the top row block from right to left. ! kb is the column index of the current block reflector in ! the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) if( mb1-kb-knb+1==0_${ik}$ ) then ! in stdlib${ii}$_slarfb_gett parameters, when m=0, then the matrix b ! does not exist, hence we need to pass a dummy array ! reference dummy(1,1) to b with lddummy=1. call stdlib${ii}$_clarfb_gett( 'N', 0_${ik}$, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, kb ), lda,& dummy( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work, knb ) else call stdlib${ii}$_clarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do work( 1_${ik}$ ) = cmplx( lworkopt,KIND=sp) return end subroutine stdlib${ii}$_cungtsqr_row pure module subroutine stdlib${ii}$_zungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! ZUNGTSQR_ROW generates an M-by-N complex matrix Q_out with !! orthonormal columns from the output of ZLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary !! matrices Q(k)_in of order M, which are returned by ZLATSQR in !! a special format. !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! The input matrices Q(k)_in are stored in row and column blocks in A. !! See the documentation of ZLATSQR for more details on the format of !! Q(k)_in, where each Q(k)_in is represented by block Householder !! transformations. This routine calls an auxiliary routine ZLARFB_GETT, !! where the computation is performed on each individual block. The !! algorithm first sweeps NB-sized column blocks from the right to left !! starting in the bottom row block and continues to the top row block !! (hence _ROW in the routine name). This sweep is in reverse order of !! the order in which ZLATSQR generates the output blocks. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: t(ldt,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & num_all_row_blocks, jb_t, ib, imb, kb, kb_last, knb, mb1 ! Local Arrays complex(dp) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ lquery = lwork==-1_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else if( lwork<1_${ik}$ .and. .not.lquery ) then info = -10_${ik}$ end if nblocal = min( nb, n ) ! determine the workspace size. if( info==0_${ik}$ ) then lworkopt = nblocal * max( nblocal, ( n - nblocal ) ) end if ! handle error in the input parameters and handle the workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZUNGTSQR_ROW', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=dp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=dp) return end if ! (0) set the upper-triangular part of the matrix a to zero and ! its diagonal elements to one. call stdlib${ii}$_zlaset('U', m, n, czero, cone, a, lda ) ! kb_last is the column index of the last column block reflector ! in the matrices t and v. kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1_${ik}$ ! (1) bottom-up loop over row blocks of a, except the top row block. ! note: if mb>=m, then the loop is never executed. if ( mb<m ) then ! mb2 is the row blocking size for the row blocks before the ! first top row block in the matrix a. ib is the row index for ! the row blocks in the matrix a before the first top row block. ! ib_bottom is the row index for the last bottom row block ! in the matrix a. jb_t is the column index of the corresponding ! column block in the matrix t. ! initialize variables. ! num_all_row_blocks is the number of row blocks in the matrix a ! including the first row block. mb2 = mb - n m_plus_one = m + 1_${ik}$ itmp = ( m - mb - 1_${ik}$ ) / mb2 ib_bottom = itmp * mb2 + mb + 1_${ik}$ num_all_row_blocks = itmp + 2_${ik}$ jb_t = num_all_row_blocks * n + 1_${ik}$ do ib = ib_bottom, mb+1, -mb2 ! determine the block size imb for the current row block ! in the matrix a. imb = min( m_plus_one - ib, mb2 ) ! determine the column index jb_t for the current column block ! in the matrix t. jb_t = jb_t - n ! apply column blocks of h in the row block from right to left. ! kb is the column index of the current column block reflector ! in the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) call stdlib${ii}$_zlarfb_gett( 'I', imb, n-kb+1, knb,t( 1_${ik}$, jb_t+kb-1 ), ldt, a( kb, & kb ), lda,a( ib, kb ), lda, work, knb ) end do end do end if ! (2) top row block of a. ! note: if mb>=m, then we have only one row block of a of size m ! and we work on the entire matrix a. mb1 = min( mb, m ) ! apply column blocks of h in the top row block from right to left. ! kb is the column index of the current block reflector in ! the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) if( mb1-kb-knb+1==0_${ik}$ ) then ! in stdlib${ii}$_slarfb_gett parameters, when m=0, then the matrix b ! does not exist, hence we need to pass a dummy array ! reference dummy(1,1) to b with lddummy=1. call stdlib${ii}$_zlarfb_gett( 'N', 0_${ik}$, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, kb ), lda,& dummy( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work, knb ) else call stdlib${ii}$_zlarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do work( 1_${ik}$ ) = cmplx( lworkopt,KIND=dp) return end subroutine stdlib${ii}$_zungtsqr_row #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$ungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! ZUNGTSQR_ROW: generates an M-by-N complex matrix Q_out with !! orthonormal columns from the output of ZLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary !! matrices Q(k)_in of order M, which are returned by ZLATSQR in !! a special format. !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! The input matrices Q(k)_in are stored in row and column blocks in A. !! See the documentation of ZLATSQR for more details on the format of !! Q(k)_in, where each Q(k)_in is represented by block Householder !! transformations. This routine calls an auxiliary routine ZLARFB_GETT, !! where the computation is performed on each individual block. The !! algorithm first sweeps NB-sized column blocks from the right to left !! starting in the bottom row block and continues to the top row block !! (hence _ROW in the routine name). This sweep is in reverse order of !! the order in which ZLATSQR generates the output blocks. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: t(ldt,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & num_all_row_blocks, jb_t, ib, imb, kb, kb_last, knb, mb1 ! Local Arrays complex(${ck}$) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ lquery = lwork==-1_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else if( lwork<1_${ik}$ .and. .not.lquery ) then info = -10_${ik}$ end if nblocal = min( nb, n ) ! determine the workspace size. if( info==0_${ik}$ ) then lworkopt = nblocal * max( nblocal, ( n - nblocal ) ) end if ! handle error in the input parameters and handle the workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZUNGTSQR_ROW', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=${ck}$) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = cmplx( lworkopt,KIND=${ck}$) return end if ! (0) set the upper-triangular part of the matrix a to zero and ! its diagonal elements to one. call stdlib${ii}$_${ci}$laset('U', m, n, czero, cone, a, lda ) ! kb_last is the column index of the last column block reflector ! in the matrices t and v. kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1_${ik}$ ! (1) bottom-up loop over row blocks of a, except the top row block. ! note: if mb>=m, then the loop is never executed. if ( mb<m ) then ! mb2 is the row blocking size for the row blocks before the ! first top row block in the matrix a. ib is the row index for ! the row blocks in the matrix a before the first top row block. ! ib_bottom is the row index for the last bottom row block ! in the matrix a. jb_t is the column index of the corresponding ! column block in the matrix t. ! initialize variables. ! num_all_row_blocks is the number of row blocks in the matrix a ! including the first row block. mb2 = mb - n m_plus_one = m + 1_${ik}$ itmp = ( m - mb - 1_${ik}$ ) / mb2 ib_bottom = itmp * mb2 + mb + 1_${ik}$ num_all_row_blocks = itmp + 2_${ik}$ jb_t = num_all_row_blocks * n + 1_${ik}$ do ib = ib_bottom, mb+1, -mb2 ! determine the block size imb for the current row block ! in the matrix a. imb = min( m_plus_one - ib, mb2 ) ! determine the column index jb_t for the current column block ! in the matrix t. jb_t = jb_t - n ! apply column blocks of h in the row block from right to left. ! kb is the column index of the current column block reflector ! in the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) call stdlib${ii}$_${ci}$larfb_gett( 'I', imb, n-kb+1, knb,t( 1_${ik}$, jb_t+kb-1 ), ldt, a( kb, & kb ), lda,a( ib, kb ), lda, work, knb ) end do end do end if ! (2) top row block of a. ! note: if mb>=m, then we have only one row block of a of size m ! and we work on the entire matrix a. mb1 = min( mb, m ) ! apply column blocks of h in the top row block from right to left. ! kb is the column index of the current block reflector in ! the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) if( mb1-kb-knb+1==0_${ik}$ ) then ! in stdlib${ii}$_dlarfb_gett parameters, when m=0, then the matrix b ! does not exist, hence we need to pass a dummy array ! reference dummy(1,1) to b with lddummy=1. call stdlib${ii}$_${ci}$larfb_gett( 'N', 0_${ik}$, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, kb ), lda,& dummy( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work, knb ) else call stdlib${ii}$_${ci}$larfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do work( 1_${ik}$ ) = cmplx( lworkopt,KIND=${ck}$) return end subroutine stdlib${ii}$_${ci}$ungtsqr_row #:endif #:endfor pure module subroutine stdlib${ii}$_sorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! SORGTSQR generates an M-by-N real matrix Q_out with orthonormal columns, !! which are the first N columns of a product of real orthogonal !! matrices of order M which are returned by SLATSQR !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! See the documentation for SLATSQR. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: t(ldt,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions ! Executable Statements ! test the input parameters lquery = lwork==-1_${ik}$ info = 0_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array c(ldc, n) and work(lwork) ! in the call to stdlib${ii}$_slamtsqr. see the documentation for stdlib${ii}$_slamtsqr. if( lwork<2_${ik}$ .and. (.not.lquery) ) then info = -10_${ik}$ else ! set block size for column blocks nblocal = min( nb, n ) ! lwork = -1, then set the size for the array c(ldc,n) ! in stdlib${ii}$_slamtsqr call and set the optimal size of the work array ! work(lwork) in stdlib${ii}$_slamtsqr call. ldc = m lc = ldc*n lw = n * nblocal lworkopt = lc+lw if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -10_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SORGTSQR', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end if ! (1) form explicitly the tall-skinny m-by-n left submatrix q1_in ! of m-by-m orthogonal matrix q_in, which is implicitly stored in ! the subdiagonal part of input array a and in the input array t. ! perform by the following operation using the routine stdlib${ii}$_slamtsqr. ! q1_in = q_in * ( i ), where i is a n-by-n identity matrix, ! ( 0 ) 0 is a (m-n)-by-n zero matrix. ! (1a) form m-by-n matrix in the array work(1:ldc*n) with ones ! on the diagonal and zeros elsewhere. call stdlib${ii}$_slaset( 'F', m, n, zero, one, work, ldc ) ! (1b) on input, work(1:ldc*n) stores ( i ); ! ( 0 ) ! on output, work(1:ldc*n) stores q1_in. call stdlib${ii}$_slamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & lc+1 ), lw, iinfo ) ! (2) copy the result from the part of the work array (1:m,1:n) ! with the leading dimension ldc that starts at work(1) into ! the output array a(1:m,1:n) column-by-column. do j = 1, n call stdlib${ii}$_scopy( m, work( (j-1)*ldc + 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) end do work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end subroutine stdlib${ii}$_sorgtsqr pure module subroutine stdlib${ii}$_dorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! DORGTSQR generates an M-by-N real matrix Q_out with orthonormal columns, !! which are the first N columns of a product of real orthogonal !! matrices of order M which are returned by DLATSQR !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! See the documentation for DLATSQR. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: t(ldt,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions ! Executable Statements ! test the input parameters lquery = lwork==-1_${ik}$ info = 0_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array c(ldc, n) and work(lwork) ! in the call to stdlib${ii}$_dlamtsqr. see the documentation for stdlib${ii}$_dlamtsqr. if( lwork<2_${ik}$ .and. (.not.lquery) ) then info = -10_${ik}$ else ! set block size for column blocks nblocal = min( nb, n ) ! lwork = -1, then set the size for the array c(ldc,n) ! in stdlib${ii}$_dlamtsqr call and set the optimal size of the work array ! work(lwork) in stdlib${ii}$_dlamtsqr call. ldc = m lc = ldc*n lw = n * nblocal lworkopt = lc+lw if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -10_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DORGTSQR', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end if ! (1) form explicitly the tall-skinny m-by-n left submatrix q1_in ! of m-by-m orthogonal matrix q_in, which is implicitly stored in ! the subdiagonal part of input array a and in the input array t. ! perform by the following operation using the routine stdlib${ii}$_dlamtsqr. ! q1_in = q_in * ( i ), where i is a n-by-n identity matrix, ! ( 0 ) 0 is a (m-n)-by-n zero matrix. ! (1a) form m-by-n matrix in the array work(1:ldc*n) with ones ! on the diagonal and zeros elsewhere. call stdlib${ii}$_dlaset( 'F', m, n, zero, one, work, ldc ) ! (1b) on input, work(1:ldc*n) stores ( i ); ! ( 0 ) ! on output, work(1:ldc*n) stores q1_in. call stdlib${ii}$_dlamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & lc+1 ), lw, iinfo ) ! (2) copy the result from the part of the work array (1:m,1:n) ! with the leading dimension ldc that starts at work(1) into ! the output array a(1:m,1:n) column-by-column. do j = 1, n call stdlib${ii}$_dcopy( m, work( (j-1)*ldc + 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) end do work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end subroutine stdlib${ii}$_dorgtsqr #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$orgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! DORGTSQR: generates an M-by-N real matrix Q_out with orthonormal columns, !! which are the first N columns of a product of real orthogonal !! matrices of order M which are returned by DLATSQR !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! See the documentation for DLATSQR. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(in) :: t(ldt,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions ! Executable Statements ! test the input parameters lquery = lwork==-1_${ik}$ info = 0_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array c(ldc, n) and work(lwork) ! in the call to stdlib${ii}$_${ri}$lamtsqr. see the documentation for stdlib${ii}$_${ri}$lamtsqr. if( lwork<2_${ik}$ .and. (.not.lquery) ) then info = -10_${ik}$ else ! set block size for column blocks nblocal = min( nb, n ) ! lwork = -1, then set the size for the array c(ldc,n) ! in stdlib${ii}$_${ri}$lamtsqr call and set the optimal size of the work array ! work(lwork) in stdlib${ii}$_${ri}$lamtsqr call. ldc = m lc = ldc*n lw = n * nblocal lworkopt = lc+lw if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -10_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DORGTSQR', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end if ! (1) form explicitly the tall-skinny m-by-n left submatrix q1_in ! of m-by-m orthogonal matrix q_in, which is implicitly stored in ! the subdiagonal part of input array a and in the input array t. ! perform by the following operation using the routine stdlib${ii}$_${ri}$lamtsqr. ! q1_in = q_in * ( i ), where i is a n-by-n identity matrix, ! ( 0 ) 0 is a (m-n)-by-n zero matrix. ! (1a) form m-by-n matrix in the array work(1:ldc*n) with ones ! on the diagonal and zeros elsewhere. call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, one, work, ldc ) ! (1b) on input, work(1:ldc*n) stores ( i ); ! ( 0 ) ! on output, work(1:ldc*n) stores q1_in. call stdlib${ii}$_${ri}$lamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & lc+1 ), lw, iinfo ) ! (2) copy the result from the part of the work array (1:m,1:n) ! with the leading dimension ldc that starts at work(1) into ! the output array a(1:m,1:n) column-by-column. do j = 1, n call stdlib${ii}$_${ri}$copy( m, work( (j-1)*ldc + 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) end do work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end subroutine stdlib${ii}$_${ri}$orgtsqr #:endif #:endfor pure module subroutine stdlib${ii}$_sorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! SORGTSQR_ROW generates an M-by-N real matrix Q_out with !! orthonormal columns from the output of SLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary !! matrices Q(k)_in of order M, which are returned by SLATSQR in !! a special format. !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! The input matrices Q(k)_in are stored in row and column blocks in A. !! See the documentation of SLATSQR for more details on the format of !! Q(k)_in, where each Q(k)_in is represented by block Householder !! transformations. This routine calls an auxiliary routine SLARFB_GETT, !! where the computation is performed on each individual block. The !! algorithm first sweeps NB-sized column blocks from the right to left !! starting in the bottom row block and continues to the top row block !! (hence _ROW in the routine name). This sweep is in reverse order of !! the order in which SLATSQR generates the output blocks. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: t(ldt,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & num_all_row_blocks, jb_t, ib, imb, kb, kb_last, knb, mb1 ! Local Arrays real(sp) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ lquery = lwork==-1_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else if( lwork<1_${ik}$ .and. .not.lquery ) then info = -10_${ik}$ end if nblocal = min( nb, n ) ! determine the workspace size. if( info==0_${ik}$ ) then lworkopt = nblocal * max( nblocal, ( n - nblocal ) ) end if ! handle error in the input parameters and handle the workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SORGTSQR_ROW', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end if ! (0) set the upper-triangular part of the matrix a to zero and ! its diagonal elements to one. call stdlib${ii}$_slaset('U', m, n, zero, one, a, lda ) ! kb_last is the column index of the last column block reflector ! in the matrices t and v. kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1_${ik}$ ! (1) bottom-up loop over row blocks of a, except the top row block. ! note: if mb>=m, then the loop is never executed. if ( mb<m ) then ! mb2 is the row blocking size for the row blocks before the ! first top row block in the matrix a. ib is the row index for ! the row blocks in the matrix a before the first top row block. ! ib_bottom is the row index for the last bottom row block ! in the matrix a. jb_t is the column index of the corresponding ! column block in the matrix t. ! initialize variables. ! num_all_row_blocks is the number of row blocks in the matrix a ! including the first row block. mb2 = mb - n m_plus_one = m + 1_${ik}$ itmp = ( m - mb - 1_${ik}$ ) / mb2 ib_bottom = itmp * mb2 + mb + 1_${ik}$ num_all_row_blocks = itmp + 2_${ik}$ jb_t = num_all_row_blocks * n + 1_${ik}$ do ib = ib_bottom, mb+1, -mb2 ! determine the block size imb for the current row block ! in the matrix a. imb = min( m_plus_one - ib, mb2 ) ! determine the column index jb_t for the current column block ! in the matrix t. jb_t = jb_t - n ! apply column blocks of h in the row block from right to left. ! kb is the column index of the current column block reflector ! in the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) call stdlib${ii}$_slarfb_gett( 'I', imb, n-kb+1, knb,t( 1_${ik}$, jb_t+kb-1 ), ldt, a( kb, & kb ), lda,a( ib, kb ), lda, work, knb ) end do end do end if ! (2) top row block of a. ! note: if mb>=m, then we have only one row block of a of size m ! and we work on the entire matrix a. mb1 = min( mb, m ) ! apply column blocks of h in the top row block from right to left. ! kb is the column index of the current block reflector in ! the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) if( mb1-kb-knb+1==0_${ik}$ ) then ! in stdlib${ii}$_slarfb_gett parameters, when m=0, then the matrix b ! does not exist, hence we need to pass a dummy array ! reference dummy(1,1) to b with lddummy=1. call stdlib${ii}$_slarfb_gett( 'N', 0_${ik}$, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, kb ), lda,& dummy( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work, knb ) else call stdlib${ii}$_slarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end subroutine stdlib${ii}$_sorgtsqr_row pure module subroutine stdlib${ii}$_dorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! DORGTSQR_ROW generates an M-by-N real matrix Q_out with !! orthonormal columns from the output of DLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary !! matrices Q(k)_in of order M, which are returned by DLATSQR in !! a special format. !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! The input matrices Q(k)_in are stored in row and column blocks in A. !! See the documentation of DLATSQR for more details on the format of !! Q(k)_in, where each Q(k)_in is represented by block Householder !! transformations. This routine calls an auxiliary routine DLARFB_GETT, !! where the computation is performed on each individual block. The !! algorithm first sweeps NB-sized column blocks from the right to left !! starting in the bottom row block and continues to the top row block !! (hence _ROW in the routine name). This sweep is in reverse order of !! the order in which DLATSQR generates the output blocks. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: t(ldt,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & num_all_row_blocks, jb_t, ib, imb, kb, kb_last, knb, mb1 ! Local Arrays real(dp) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ lquery = lwork==-1_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else if( lwork<1_${ik}$ .and. .not.lquery ) then info = -10_${ik}$ end if nblocal = min( nb, n ) ! determine the workspace size. if( info==0_${ik}$ ) then lworkopt = nblocal * max( nblocal, ( n - nblocal ) ) end if ! handle error in the input parameters and handle the workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DORGTSQR_ROW', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end if ! (0) set the upper-triangular part of the matrix a to zero and ! its diagonal elements to one. call stdlib${ii}$_dlaset('U', m, n, zero, one, a, lda ) ! kb_last is the column index of the last column block reflector ! in the matrices t and v. kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1_${ik}$ ! (1) bottom-up loop over row blocks of a, except the top row block. ! note: if mb>=m, then the loop is never executed. if ( mb<m ) then ! mb2 is the row blocking size for the row blocks before the ! first top row block in the matrix a. ib is the row index for ! the row blocks in the matrix a before the first top row block. ! ib_bottom is the row index for the last bottom row block ! in the matrix a. jb_t is the column index of the corresponding ! column block in the matrix t. ! initialize variables. ! num_all_row_blocks is the number of row blocks in the matrix a ! including the first row block. mb2 = mb - n m_plus_one = m + 1_${ik}$ itmp = ( m - mb - 1_${ik}$ ) / mb2 ib_bottom = itmp * mb2 + mb + 1_${ik}$ num_all_row_blocks = itmp + 2_${ik}$ jb_t = num_all_row_blocks * n + 1_${ik}$ do ib = ib_bottom, mb+1, -mb2 ! determine the block size imb for the current row block ! in the matrix a. imb = min( m_plus_one - ib, mb2 ) ! determine the column index jb_t for the current column block ! in the matrix t. jb_t = jb_t - n ! apply column blocks of h in the row block from right to left. ! kb is the column index of the current column block reflector ! in the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) call stdlib${ii}$_dlarfb_gett( 'I', imb, n-kb+1, knb,t( 1_${ik}$, jb_t+kb-1 ), ldt, a( kb, & kb ), lda,a( ib, kb ), lda, work, knb ) end do end do end if ! (2) top row block of a. ! note: if mb>=m, then we have only one row block of a of size m ! and we work on the entire matrix a. mb1 = min( mb, m ) ! apply column blocks of h in the top row block from right to left. ! kb is the column index of the current block reflector in ! the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) if( mb1-kb-knb+1==0_${ik}$ ) then ! in stdlib${ii}$_slarfb_gett parameters, when m=0, then the matrix b ! does not exist, hence we need to pass a dummy array ! reference dummy(1,1) to b with lddummy=1. call stdlib${ii}$_dlarfb_gett( 'N', 0_${ik}$, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, kb ), lda,& dummy( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work, knb ) else call stdlib${ii}$_dlarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end subroutine stdlib${ii}$_dorgtsqr_row #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$orgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! DORGTSQR_ROW: generates an M-by-N real matrix Q_out with !! orthonormal columns from the output of DLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary !! matrices Q(k)_in of order M, which are returned by DLATSQR in !! a special format. !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! The input matrices Q(k)_in are stored in row and column blocks in A. !! See the documentation of DLATSQR for more details on the format of !! Q(k)_in, where each Q(k)_in is represented by block Householder !! transformations. This routine calls an auxiliary routine DLARFB_GETT, !! where the computation is performed on each individual block. The !! algorithm first sweeps NB-sized column blocks from the right to left !! starting in the bottom row block and continues to the top row block !! (hence _ROW in the routine name). This sweep is in reverse order of !! the order in which DLATSQR generates the output blocks. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, mb, nb ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(in) :: t(ldt,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & num_all_row_blocks, jb_t, ib, imb, kb, kb_last, knb, mb1 ! Local Arrays real(${rk}$) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ lquery = lwork==-1_${ik}$ if( m<0_${ik}$ ) then info = -1_${ik}$ else if( n<0_${ik}$ .or. m<n ) then info = -2_${ik}$ else if( mb<=n ) then info = -3_${ik}$ else if( nb<1_${ik}$ ) then info = -4_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -6_${ik}$ else if( ldt<max( 1_${ik}$, min( nb, n ) ) ) then info = -8_${ik}$ else if( lwork<1_${ik}$ .and. .not.lquery ) then info = -10_${ik}$ end if nblocal = min( nb, n ) ! determine the workspace size. if( info==0_${ik}$ ) then lworkopt = nblocal * max( nblocal, ( n - nblocal ) ) end if ! handle error in the input parameters and handle the workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DORGTSQR_ROW', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end if ! (0) set the upper-triangular part of the matrix a to zero and ! its diagonal elements to one. call stdlib${ii}$_${ri}$laset('U', m, n, zero, one, a, lda ) ! kb_last is the column index of the last column block reflector ! in the matrices t and v. kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1_${ik}$ ! (1) bottom-up loop over row blocks of a, except the top row block. ! note: if mb>=m, then the loop is never executed. if ( mb<m ) then ! mb2 is the row blocking size for the row blocks before the ! first top row block in the matrix a. ib is the row index for ! the row blocks in the matrix a before the first top row block. ! ib_bottom is the row index for the last bottom row block ! in the matrix a. jb_t is the column index of the corresponding ! column block in the matrix t. ! initialize variables. ! num_all_row_blocks is the number of row blocks in the matrix a ! including the first row block. mb2 = mb - n m_plus_one = m + 1_${ik}$ itmp = ( m - mb - 1_${ik}$ ) / mb2 ib_bottom = itmp * mb2 + mb + 1_${ik}$ num_all_row_blocks = itmp + 2_${ik}$ jb_t = num_all_row_blocks * n + 1_${ik}$ do ib = ib_bottom, mb+1, -mb2 ! determine the block size imb for the current row block ! in the matrix a. imb = min( m_plus_one - ib, mb2 ) ! determine the column index jb_t for the current column block ! in the matrix t. jb_t = jb_t - n ! apply column blocks of h in the row block from right to left. ! kb is the column index of the current column block reflector ! in the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) call stdlib${ii}$_${ri}$larfb_gett( 'I', imb, n-kb+1, knb,t( 1_${ik}$, jb_t+kb-1 ), ldt, a( kb, & kb ), lda,a( ib, kb ), lda, work, knb ) end do end do end if ! (2) top row block of a. ! note: if mb>=m, then we have only one row block of a of size m ! and we work on the entire matrix a. mb1 = min( mb, m ) ! apply column blocks of h in the top row block from right to left. ! kb is the column index of the current block reflector in ! the matrices t and v. do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1_${ik}$ ) if( mb1-kb-knb+1==0_${ik}$ ) then ! in stdlib${ii}$_dlarfb_gett parameters, when m=0, then the matrix b ! does not exist, hence we need to pass a dummy array ! reference dummy(1,1) to b with lddummy=1. call stdlib${ii}$_${ri}$larfb_gett( 'N', 0_${ik}$, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, kb ), lda,& dummy( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work, knb ) else call stdlib${ii}$_${ri}$larfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end subroutine stdlib${ii}$_${ri}$orgtsqr_row #:endif #:endfor pure module subroutine stdlib${ii}$_slarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! SLARFB_GETT applies a real Householder block reflector H from the !! left to a real (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A !! stored in the array A, and a rectangular M-by-(N-K) matrix B, stored !! in the array B. The block reflector H is stored in a compact !! WY-representation, where the elementary reflectors are in the !! arrays A, B and T. See Further Details section. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments character, intent(in) :: ident integer(${ik}$), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(in) :: t(ldt,*) real(sp), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars logical(lk) :: lnotident integer(${ik}$) :: i, j ! Executable Statements ! quick return if possible if( m<0 .or. n<=0 .or. k==0 .or. k>n )return lnotident = .not.stdlib_lsame( ident, 'I' ) ! ------------------------------------------------------------------ ! first step. computation of the column block 2: ! ( a2 ) := h * ( a2 ) ! ( b2 ) ( b2 ) ! ------------------------------------------------------------------ if( n>k ) then ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k call stdlib${ii}$_scopy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**t) * w2 = (a1**t) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_strmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**t) * b2 = w2 + (b1**t) * b2 ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_sgemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1_${ik}$, k+1 ), ldb, one, work, & ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_sgemm( 'N', 'N', m, n-k, k, -one, b, ldb,work, ldwork, one, b( 1_${ik}$, k+& 1_${ik}$ ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_strmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = ! = a(1:k, k+1:n-k) - work(1:k, 1:n-k), ! column-by-column. do j = 1, n-k do i = 1, k a( i, k+j ) = a( i, k+j ) - work( i, j ) end do end do end if ! ------------------------------------------------------------------ ! second step. computation of the column block 1: ! ( a1 ) := h * ( a1 ) ! ( b1 ) ( 0 ) ! ------------------------------------------------------------------ ! col1_(1) compute w1: = a1. copy the upper-triangular ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k call stdlib${ii}$_scopy( j, a( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 do i = j + 1, k work( i, j ) = zero end do end do if( lnotident ) then ! col1_(2) compute w1: = (v1**t) * w1 = (a1**t) * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_strmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. if( m>0_${ik}$ ) then call stdlib${ii}$_strmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular on input with zeroes below the diagonal, ! and square on output. call stdlib${ii}$_strmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, ! if not ident, a1 is upper-triangular on output, ! w1 is upper-triangular. ! col1_(6)_a compute elements of a1 below the diagonal. do j = 1, k - 1 do i = j + 1, k a( i, j ) = - work( i, j ) end do end do end if ! col1_(6)_b compute elements of a1 on and above the diagonal. do j = 1, k do i = 1, j a( i, j ) = a( i, j ) - work( i, j ) end do end do return end subroutine stdlib${ii}$_slarfb_gett pure module subroutine stdlib${ii}$_dlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! DLARFB_GETT applies a real Householder block reflector H from the !! left to a real (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A !! stored in the array A, and a rectangular M-by-(N-K) matrix B, stored !! in the array B. The block reflector H is stored in a compact !! WY-representation, where the elementary reflectors are in the !! arrays A, B and T. See Further Details section. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments character, intent(in) :: ident integer(${ik}$), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(in) :: t(ldt,*) real(dp), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars logical(lk) :: lnotident integer(${ik}$) :: i, j ! Executable Statements ! quick return if possible if( m<0 .or. n<=0 .or. k==0 .or. k>n )return lnotident = .not.stdlib_lsame( ident, 'I' ) ! ------------------------------------------------------------------ ! first step. computation of the column block 2: ! ( a2 ) := h * ( a2 ) ! ( b2 ) ( b2 ) ! ------------------------------------------------------------------ if( n>k ) then ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k call stdlib${ii}$_dcopy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**t) * w2 = (a1**t) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**t) * b2 = w2 + (b1**t) * b2 ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_dgemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1_${ik}$, k+1 ), ldb, one, work, & ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_dgemm( 'N', 'N', m, n-k, k, -one, b, ldb,work, ldwork, one, b( 1_${ik}$, k+& 1_${ik}$ ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_dtrmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = ! = a(1:k, k+1:n-k) - work(1:k, 1:n-k), ! column-by-column. do j = 1, n-k do i = 1, k a( i, k+j ) = a( i, k+j ) - work( i, j ) end do end do end if ! ------------------------------------------------------------------ ! second step. computation of the column block 1: ! ( a1 ) := h * ( a1 ) ! ( b1 ) ( 0 ) ! ------------------------------------------------------------------ ! col1_(1) compute w1: = a1. copy the upper-triangular ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k call stdlib${ii}$_dcopy( j, a( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 do i = j + 1, k work( i, j ) = zero end do end do if( lnotident ) then ! col1_(2) compute w1: = (v1**t) * w1 = (a1**t) * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. if( m>0_${ik}$ ) then call stdlib${ii}$_dtrmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular on input with zeroes below the diagonal, ! and square on output. call stdlib${ii}$_dtrmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, ! if not ident, a1 is upper-triangular on output, ! w1 is upper-triangular. ! col1_(6)_a compute elements of a1 below the diagonal. do j = 1, k - 1 do i = j + 1, k a( i, j ) = - work( i, j ) end do end do end if ! col1_(6)_b compute elements of a1 on and above the diagonal. do j = 1, k do i = 1, j a( i, j ) = a( i, j ) - work( i, j ) end do end do return end subroutine stdlib${ii}$_dlarfb_gett #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$larfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! DLARFB_GETT: applies a real Householder block reflector H from the !! left to a real (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A !! stored in the array A, and a rectangular M-by-(N-K) matrix B, stored !! in the array B. The block reflector H is stored in a compact !! WY-representation, where the elementary reflectors are in the !! arrays A, B and T. See Further Details section. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments character, intent(in) :: ident integer(${ik}$), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(in) :: t(ldt,*) real(${rk}$), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars logical(lk) :: lnotident integer(${ik}$) :: i, j ! Executable Statements ! quick return if possible if( m<0 .or. n<=0 .or. k==0 .or. k>n )return lnotident = .not.stdlib_lsame( ident, 'I' ) ! ------------------------------------------------------------------ ! first step. computation of the column block 2: ! ( a2 ) := h * ( a2 ) ! ( b2 ) ( b2 ) ! ------------------------------------------------------------------ if( n>k ) then ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k call stdlib${ii}$_${ri}$copy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**t) * w2 = (a1**t) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**t) * b2 = w2 + (b1**t) * b2 ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_${ri}$gemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1_${ik}$, k+1 ), ldb, one, work, & ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n-k, k, -one, b, ldb,work, ldwork, one, b( 1_${ik}$, k+& 1_${ik}$ ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = ! = a(1:k, k+1:n-k) - work(1:k, 1:n-k), ! column-by-column. do j = 1, n-k do i = 1, k a( i, k+j ) = a( i, k+j ) - work( i, j ) end do end do end if ! ------------------------------------------------------------------ ! second step. computation of the column block 1: ! ( a1 ) := h * ( a1 ) ! ( b1 ) ( 0 ) ! ------------------------------------------------------------------ ! col1_(1) compute w1: = a1. copy the upper-triangular ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k call stdlib${ii}$_${ri}$copy( j, a( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 do i = j + 1, k work( i, j ) = zero end do end do if( lnotident ) then ! col1_(2) compute w1: = (v1**t) * w1 = (a1**t) * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. if( m>0_${ik}$ ) then call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular on input with zeroes below the diagonal, ! and square on output. call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, ! if not ident, a1 is upper-triangular on output, ! w1 is upper-triangular. ! col1_(6)_a compute elements of a1 below the diagonal. do j = 1, k - 1 do i = j + 1, k a( i, j ) = - work( i, j ) end do end do end if ! col1_(6)_b compute elements of a1 on and above the diagonal. do j = 1, k do i = 1, j a( i, j ) = a( i, j ) - work( i, j ) end do end do return end subroutine stdlib${ii}$_${ri}$larfb_gett #:endif #:endfor pure module subroutine stdlib${ii}$_clarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! CLARFB_GETT applies a complex Householder block reflector H from the !! left to a complex (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A !! stored in the array A, and a rectangular M-by-(N-K) matrix B, stored !! in the array B. The block reflector H is stored in a compact !! WY-representation, where the elementary reflectors are in the !! arrays A, B and T. See Further Details section. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments character, intent(in) :: ident integer(${ik}$), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(in) :: t(ldt,*) complex(sp), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars logical(lk) :: lnotident integer(${ik}$) :: i, j ! Executable Statements ! quick return if possible if( m<0 .or. n<=0 .or. k==0 .or. k>n )return lnotident = .not.stdlib_lsame( ident, 'I' ) ! ------------------------------------------------------------------ ! first step. computation of the column block 2: ! ( a2 ) := h * ( a2 ) ! ( b2 ) ( b2 ) ! ------------------------------------------------------------------ if( n>k ) then ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k call stdlib${ii}$_ccopy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**h) * w2 = (a1**h) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**h) * b2 = w2 + (b1**h) * b2 ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_cgemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1_${ik}$, k+1 ), ldb, cone, & work, ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_cgemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1_${ik}$, & k+1 ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_ctrmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = ! = a(1:k, k+1:n-k) - work(1:k, 1:n-k), ! column-by-column. do j = 1, n-k do i = 1, k a( i, k+j ) = a( i, k+j ) - work( i, j ) end do end do end if ! ------------------------------------------------------------------ ! second step. computation of the column block 1: ! ( a1 ) := h * ( a1 ) ! ( b1 ) ( 0 ) ! ------------------------------------------------------------------ ! col1_(1) compute w1: = a1. copy the upper-triangular ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k call stdlib${ii}$_ccopy( j, a( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 do i = j + 1, k work( i, j ) = czero end do end do if( lnotident ) then ! col1_(2) compute w1: = (v1**h) * w1 = (a1**h) * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. if( m>0_${ik}$ ) then call stdlib${ii}$_ctrmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular on input with zeroes below the diagonal, ! and square on output. call stdlib${ii}$_ctrmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, ! if not ident, a1 is upper-triangular on output, ! w1 is upper-triangular. ! col1_(6)_a compute elements of a1 below the diagonal. do j = 1, k - 1 do i = j + 1, k a( i, j ) = - work( i, j ) end do end do end if ! col1_(6)_b compute elements of a1 on and above the diagonal. do j = 1, k do i = 1, j a( i, j ) = a( i, j ) - work( i, j ) end do end do return end subroutine stdlib${ii}$_clarfb_gett pure module subroutine stdlib${ii}$_zlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! ZLARFB_GETT applies a complex Householder block reflector H from the !! left to a complex (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A !! stored in the array A, and a rectangular M-by-(N-K) matrix B, stored !! in the array B. The block reflector H is stored in a compact !! WY-representation, where the elementary reflectors are in the !! arrays A, B and T. See Further Details section. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments character, intent(in) :: ident integer(${ik}$), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(in) :: t(ldt,*) complex(dp), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars logical(lk) :: lnotident integer(${ik}$) :: i, j ! Executable Statements ! quick return if possible if( m<0 .or. n<=0 .or. k==0 .or. k>n )return lnotident = .not.stdlib_lsame( ident, 'I' ) ! ------------------------------------------------------------------ ! first step. computation of the column block 2: ! ( a2 ) := h * ( a2 ) ! ( b2 ) ( b2 ) ! ------------------------------------------------------------------ if( n>k ) then ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k call stdlib${ii}$_zcopy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**h) * w2 = (a1**h) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**h) * b2 = w2 + (b1**h) * b2 ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_zgemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1_${ik}$, k+1 ), ldb, cone, & work, ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_zgemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1_${ik}$, & k+1 ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_ztrmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = ! = a(1:k, k+1:n-k) - work(1:k, 1:n-k), ! column-by-column. do j = 1, n-k do i = 1, k a( i, k+j ) = a( i, k+j ) - work( i, j ) end do end do end if ! ------------------------------------------------------------------ ! second step. computation of the column block 1: ! ( a1 ) := h * ( a1 ) ! ( b1 ) ( 0 ) ! ------------------------------------------------------------------ ! col1_(1) compute w1: = a1. copy the upper-triangular ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k call stdlib${ii}$_zcopy( j, a( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 do i = j + 1, k work( i, j ) = czero end do end do if( lnotident ) then ! col1_(2) compute w1: = (v1**h) * w1 = (a1**h) * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. if( m>0_${ik}$ ) then call stdlib${ii}$_ztrmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular on input with zeroes below the diagonal, ! and square on output. call stdlib${ii}$_ztrmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, ! if not ident, a1 is upper-triangular on output, ! w1 is upper-triangular. ! col1_(6)_a compute elements of a1 below the diagonal. do j = 1, k - 1 do i = j + 1, k a( i, j ) = - work( i, j ) end do end do end if ! col1_(6)_b compute elements of a1 on and above the diagonal. do j = 1, k do i = 1, j a( i, j ) = a( i, j ) - work( i, j ) end do end do return end subroutine stdlib${ii}$_zlarfb_gett #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$larfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! ZLARFB_GETT: applies a complex Householder block reflector H from the !! left to a complex (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A !! stored in the array A, and a rectangular M-by-(N-K) matrix B, stored !! in the array B. The block reflector H is stored in a compact !! WY-representation, where the elementary reflectors are in the !! arrays A, B and T. See Further Details section. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone ! Scalar Arguments character, intent(in) :: ident integer(${ik}$), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(in) :: t(ldt,*) complex(${ck}$), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars logical(lk) :: lnotident integer(${ik}$) :: i, j ! Executable Statements ! quick return if possible if( m<0 .or. n<=0 .or. k==0 .or. k>n )return lnotident = .not.stdlib_lsame( ident, 'I' ) ! ------------------------------------------------------------------ ! first step. computation of the column block 2: ! ( a2 ) := h * ( a2 ) ! ( b2 ) ( b2 ) ! ------------------------------------------------------------------ if( n>k ) then ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k call stdlib${ii}$_${ci}$copy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**h) * w2 = (a1**h) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**h) * b2 = w2 + (b1**h) * b2 ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_${ci}$gemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1_${ik}$, k+1 ), ldb, cone, & work, ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. if( m>0_${ik}$ ) then call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1_${ik}$, & k+1 ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = ! = a(1:k, k+1:n-k) - work(1:k, 1:n-k), ! column-by-column. do j = 1, n-k do i = 1, k a( i, k+j ) = a( i, k+j ) - work( i, j ) end do end do end if ! ------------------------------------------------------------------ ! second step. computation of the column block 1: ! ( a1 ) := h * ( a1 ) ! ( b1 ) ( 0 ) ! ------------------------------------------------------------------ ! col1_(1) compute w1: = a1. copy the upper-triangular ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k call stdlib${ii}$_${ci}$copy( j, a( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 do i = j + 1, k work( i, j ) = czero end do end do if( lnotident ) then ! col1_(2) compute w1: = (v1**h) * w1 = (a1**h) * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. if( m>0_${ik}$ ) then call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular on input with zeroes below the diagonal, ! and square on output. call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, ! if not ident, a1 is upper-triangular on output, ! w1 is upper-triangular. ! col1_(6)_a compute elements of a1 below the diagonal. do j = 1, k - 1 do i = j + 1, k a( i, j ) = - work( i, j ) end do end do end if ! col1_(6)_b compute elements of a1 on and above the diagonal. do j = 1, k do i = 1, j a( i, j ) = a( i, j ) - work( i, j ) end do end do return end subroutine stdlib${ii}$_${ci}$larfb_gett #:endif #:endfor pure module subroutine stdlib${ii}$_slamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! SLAMTSQR 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 tall skinny !! QR factorization (SLATSQR) 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, q ! 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 * nb q = m else lw = mb * nb q = n 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<k ) then info = -3_${ik}$ else if( n<0_${ik}$ ) then info = -4_${ik}$ else if( k<0_${ik}$ ) then info = -5_${ik}$ else if( k<nb .or. nb<1_${ik}$ ) then info = -7_${ik}$ else if( lda<max( 1_${ik}$, q ) ) then info = -9_${ik}$ else if( ldt<max( 1_${ik}$, nb) ) 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 ! determine the block size if it is tall skinny or short and wide if( info==0_${ik}$) then work(1_${ik}$) = lw end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SLAMTSQR', -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((mb<=k).or.(mb>=max(m,n,k))) then call stdlib${ii}$_sgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if if(left.and.notran) then ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) if (kk>0_${ik}$) then ii=m-kk+1 call stdlib${ii}$_stpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) ctr = ctr - 1_${ik}$ call stdlib${ii}$_stpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), 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:mb,1:n) call stdlib${ii}$_sgemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_sgemqrt('L','T',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) call stdlib${ii}$_stpmqrt('L','T',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_stpmqrt('L','T',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), 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.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) if (kk>0_${ik}$) then ii=n-kk+1 call stdlib${ii}$_stpmqrt('R','T',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1_${ik}$ call stdlib${ii}$_stpmqrt('R','T',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_sgemqrt('R','T',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_sgemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) call stdlib${ii}$_stpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),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}$_stpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), 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}$_slamtsqr pure module subroutine stdlib${ii}$_dlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! DLAMTSQR 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 tall skinny !! QR factorization (DLATSQR) 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, lw, ctr, q ! 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 * nb q = m else lw = mb * nb q = n 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<k ) then info = -3_${ik}$ else if( n<0_${ik}$ ) then info = -4_${ik}$ else if( k<0_${ik}$ ) then info = -5_${ik}$ else if( k<nb .or. nb<1_${ik}$ ) then info = -7_${ik}$ else if( lda<max( 1_${ik}$, q ) ) then info = -9_${ik}$ else if( ldt<max( 1_${ik}$, nb) ) 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 ! determine the block size if it is tall skinny or short and wide if( info==0_${ik}$) then work(1_${ik}$) = lw end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DLAMTSQR', -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((mb<=k).or.(mb>=max(m,n,k))) then call stdlib${ii}$_dgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if if(left.and.notran) then ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) if (kk>0_${ik}$) then ii=m-kk+1 call stdlib${ii}$_dtpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) ctr = ctr - 1_${ik}$ call stdlib${ii}$_dtpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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:mb,1:n) call stdlib${ii}$_dgemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_dgemqrt('L','T',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) call stdlib${ii}$_dtpmqrt('L','T',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_dtpmqrt('L','T',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), 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.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) if (kk>0_${ik}$) then ii=n-kk+1 call stdlib${ii}$_dtpmqrt('R','T',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1_${ik}$ call stdlib${ii}$_dtpmqrt('R','T',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_dgemqrt('R','T',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_dgemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) call stdlib${ii}$_dtpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),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}$_dtpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), 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}$_dlamtsqr #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! DLAMTSQR: 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 tall skinny !! QR factorization (DLATSQR) 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, lw, ctr, q ! 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 * nb q = m else lw = mb * nb q = n 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<k ) then info = -3_${ik}$ else if( n<0_${ik}$ ) then info = -4_${ik}$ else if( k<0_${ik}$ ) then info = -5_${ik}$ else if( k<nb .or. nb<1_${ik}$ ) then info = -7_${ik}$ else if( lda<max( 1_${ik}$, q ) ) then info = -9_${ik}$ else if( ldt<max( 1_${ik}$, nb) ) 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 ! determine the block size if it is tall skinny or short and wide if( info==0_${ik}$) then work(1_${ik}$) = lw end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DLAMTSQR', -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((mb<=k).or.(mb>=max(m,n,k))) then call stdlib${ii}$_${ri}$gemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if if(left.and.notran) then ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) if (kk>0_${ik}$) then ii=m-kk+1 call stdlib${ii}$_${ri}$tpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) ctr = ctr - 1_${ik}$ call stdlib${ii}$_${ri}$tpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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:mb,1:n) call stdlib${ii}$_${ri}$gemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_${ri}$gemqrt('L','T',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) call stdlib${ii}$_${ri}$tpmqrt('L','T',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_${ri}$tpmqrt('L','T',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), 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.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) if (kk>0_${ik}$) then ii=n-kk+1 call stdlib${ii}$_${ri}$tpmqrt('R','T',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1_${ik}$ call stdlib${ii}$_${ri}$tpmqrt('R','T',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$gemqrt('R','T',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_${ri}$gemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) call stdlib${ii}$_${ri}$tpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),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}$tpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), 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}$_${ri}$lamtsqr #:endif #:endfor pure module subroutine stdlib${ii}$_clamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! CLAMTSQR 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 tall skinny !! QR factorization (CLATSQR) 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, q ! 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 * nb q = m else lw = m * nb q = n 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<k ) then info = -3_${ik}$ else if( n<0_${ik}$ ) then info = -4_${ik}$ else if( k<0_${ik}$ ) then info = -5_${ik}$ else if( k<nb .or. nb<1_${ik}$ ) then info = -7_${ik}$ else if( lda<max( 1_${ik}$, q ) ) then info = -9_${ik}$ else if( ldt<max( 1_${ik}$, nb) ) 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 ! determine the block size if it is tall skinny or short and wide if( info==0_${ik}$) then work(1_${ik}$) = lw end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CLAMTSQR', -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((mb<=k).or.(mb>=max(m,n,k))) then call stdlib${ii}$_cgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if if(left.and.notran) then ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) if (kk>0_${ik}$) then ii=m-kk+1 call stdlib${ii}$_ctpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) ctr = ctr - 1_${ik}$ call stdlib${ii}$_ctpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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:mb,1:n) call stdlib${ii}$_cgemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_cgemqrt('L','C',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) call stdlib${ii}$_ctpmqrt('L','C',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_ctpmqrt('L','C',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), 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.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) if (kk>0_${ik}$) then ii=n-kk+1 call stdlib${ii}$_ctpmqrt('R','C',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1_${ik}$ call stdlib${ii}$_ctpmqrt('R','C',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_cgemqrt('R','C',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_cgemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) call stdlib${ii}$_ctpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_ctpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), 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}$_clamtsqr pure module subroutine stdlib${ii}$_zlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! ZLAMTSQR 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 tall skinny !! QR factorization (ZLATSQR) 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, q ! 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 * nb q = m else lw = m * nb q = n 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<k ) then info = -3_${ik}$ else if( n<0_${ik}$ ) then info = -4_${ik}$ else if( k<0_${ik}$ ) then info = -5_${ik}$ else if( k<nb .or. nb<1_${ik}$ ) then info = -7_${ik}$ else if( lda<max( 1_${ik}$, q ) ) then info = -9_${ik}$ else if( ldt<max( 1_${ik}$, nb) ) 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 ! determine the block size if it is tall skinny or short and wide if( info==0_${ik}$) then work(1_${ik}$) = lw end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZLAMTSQR', -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((mb<=k).or.(mb>=max(m,n,k))) then call stdlib${ii}$_zgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if if(left.and.notran) then ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) if (kk>0_${ik}$) then ii=m-kk+1 call stdlib${ii}$_ztpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt ,& c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) ctr = ctr - 1_${ik}$ call stdlib${ii}$_ztpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),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:mb,1:n) call stdlib${ii}$_zgemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_zgemqrt('L','C',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) call stdlib${ii}$_ztpmqrt('L','C',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_ztpmqrt('L','C',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), 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.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) if (kk>0_${ik}$) then ii=n-kk+1 call stdlib${ii}$_ztpmqrt('R','C',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1_${ik}$ call stdlib${ii}$_ztpmqrt('R','C',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$_zgemqrt('R','C',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_zgemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) call stdlib${ii}$_ztpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),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}$_ztpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), 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}$_zlamtsqr #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! ZLAMTSQR: 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 tall skinny !! QR factorization (ZLATSQR) 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, q ! 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 * nb q = m else lw = m * nb q = n 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<k ) then info = -3_${ik}$ else if( n<0_${ik}$ ) then info = -4_${ik}$ else if( k<0_${ik}$ ) then info = -5_${ik}$ else if( k<nb .or. nb<1_${ik}$ ) then info = -7_${ik}$ else if( lda<max( 1_${ik}$, q ) ) then info = -9_${ik}$ else if( ldt<max( 1_${ik}$, nb) ) 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 ! determine the block size if it is tall skinny or short and wide if( info==0_${ik}$) then work(1_${ik}$) = lw end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZLAMTSQR', -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((mb<=k).or.(mb>=max(m,n,k))) then call stdlib${ii}$_${ci}$gemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if if(left.and.notran) then ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) if (kk>0_${ik}$) then ii=m-kk+1 call stdlib${ii}$_${ci}$tpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt ,& c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) ctr = ctr - 1_${ik}$ call stdlib${ii}$_${ci}$tpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),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:mb,1:n) call stdlib${ii}$_${ci}$gemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_${ci}$gemqrt('L','C',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) call stdlib${ii}$_${ci}$tpmqrt('L','C',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$tpmqrt('L','C',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), 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.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) if (kk>0_${ik}$) then ii=n-kk+1 call stdlib${ii}$_${ci}$tpmqrt('R','C',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), 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-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1_${ik}$ call stdlib${ii}$_${ci}$tpmqrt('R','C',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), 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}$gemqrt('R','C',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 ctr = 1_${ik}$ call stdlib${ii}$_${ci}$gemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) call stdlib${ii}$_${ci}$tpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),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}$tpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), 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}$lamtsqr #:endif #:endfor pure module subroutine stdlib${ii}$_sgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! SGETSQRHRT computes a NB2-sized column blocked QR-factorization !! of a complex M-by-N matrix A with M >= N, !! A = Q * R. !! The routine uses internally a NB1-sized column blocked and MB1-sized !! row blocked TSQR-factorization and perfors the reconstruction !! of the Householder vectors from the TSQR output. The routine also !! converts the R_tsqr factor from the TSQR-factorization output into !! the R factor that corresponds to the Householder QR-factorization, !! A = Q_tsqr * R_tsqr = Q * R. !! The output Q and R factors are stored in the same format as in SGEQRT !! (Q is in blocked compact WY-representation). See the documentation !! of SGEQRT for more details on the format. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, nb1, nb2, mb1 ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! 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. m<n ) then info = -2_${ik}$ else if( mb1<=n ) then info = -3_${ik}$ else if( nb1<1_${ik}$ ) then info = -4_${ik}$ else if( nb2<1_${ik}$ ) then info = -5_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -7_${ik}$ else if( ldt<max( 1_${ik}$, min( nb2, n ) ) ) then info = -9_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array: ! a) matrix t and work for stdlib${ii}$_slatsqr; ! b) n-by-n upper-triangular factor r_tsqr; ! c) matrix t and array work for stdlib${ii}$_sorgtsqr_row; ! d) diagonal d for stdlib${ii}$_sorhr_col. if( lwork<n*n+1 .and. .not.lquery ) then info = -11_${ik}$ else ! set block size for column blocks nb1local = min( nb1, n ) num_all_row_blocks = max( 1_${ik}$,ceiling( real( m - n,KIND=sp) / real( mb1 - n,& KIND=sp) ) ) ! length and leading dimension of work array to place ! t array in tsqr. lwt = num_all_row_blocks * n * nb1local ldwt = nb1local ! length of tsqr work array lw1 = nb1local * n ! length of stdlib${ii}$_sorgtsqr_row work array. lw2 = nb1local * max( nb1local, ( n - nb1local ) ) lworkopt = max( lwt + lw1, max( lwt+n*n+lw2, lwt+n*n+n ) ) if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -11_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SGETSQRHRT', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end if nb2local = min( nb2, n ) ! (1) perform tsqr-factorization of the m-by-n matrix a. call stdlib${ii}$_slatsqr( m, n, mb1, nb1local, a, lda, work, ldwt,work(lwt+1), lw1, iinfo ) ! (2) copy the factor r_tsqr stored in the upper-triangular part ! of a into the square matrix in the work array ! work(lwt+1:lwt+n*n) column-by-column. do j = 1, n call stdlib${ii}$_scopy( j, a( 1_${ik}$, j ), 1_${ik}$, work( lwt + n*(j-1)+1_${ik}$ ), 1_${ik}$ ) end do ! (3) generate a m-by-n matrix q with orthonormal columns from ! the result stored below the diagonal in the array a in place. call stdlib${ii}$_sorgtsqr_row( m, n, mb1, nb1local, a, lda, work, ldwt,work( lwt+n*n+1 ), & lw2, iinfo ) ! (4) perform the reconstruction of householder vectors from ! the matrix q (stored in a) in place. call stdlib${ii}$_sorhr_col( m, n, nb2local, a, lda, t, ldt,work( lwt+n*n+1 ), iinfo ) ! (5) copy the factor r_tsqr stored in the square matrix in the ! work array work(lwt+1:lwt+n*n) into the upper-triangular ! part of a. ! (6) compute from r_tsqr the factor r_hr corresponding to ! the reconstructed householder vectors, i.e. r_hr = s * r_tsqr. ! this multiplication by the sign matrix s on the left means ! changing the sign of i-th row of the matrix r_tsqr according ! to sign of the i-th diagonal element diag(i) of the matrix s. ! diag is stored in work( lwt+n*n+1 ) from the stdlib${ii}$_sorhr_col output. ! (5) and (6) can be combined in a single loop, so the rows in a ! are accessed only once. do i = 1, n if( work( lwt+n*n+i )==-one ) then do j = i, n a( i, j ) = -one * work( lwt+n*(j-1)+i ) end do else call stdlib${ii}$_scopy( n-i+1, work(lwt+n*(i-1)+i), n, a( i, i ), lda ) end if end do work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return end subroutine stdlib${ii}$_sgetsqrhrt pure module subroutine stdlib${ii}$_dgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! DGETSQRHRT computes a NB2-sized column blocked QR-factorization !! of a real M-by-N matrix A with M >= N, !! A = Q * R. !! The routine uses internally a NB1-sized column blocked and MB1-sized !! row blocked TSQR-factorization and perfors the reconstruction !! of the Householder vectors from the TSQR output. The routine also !! converts the R_tsqr factor from the TSQR-factorization output into !! the R factor that corresponds to the Householder QR-factorization, !! A = Q_tsqr * R_tsqr = Q * R. !! The output Q and R factors are stored in the same format as in DGEQRT !! (Q is in blocked compact WY-representation). See the documentation !! of DGEQRT for more details on the format. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, nb1, nb2, mb1 ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! 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. m<n ) then info = -2_${ik}$ else if( mb1<=n ) then info = -3_${ik}$ else if( nb1<1_${ik}$ ) then info = -4_${ik}$ else if( nb2<1_${ik}$ ) then info = -5_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -7_${ik}$ else if( ldt<max( 1_${ik}$, min( nb2, n ) ) ) then info = -9_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array: ! a) matrix t and work for stdlib${ii}$_dlatsqr; ! b) n-by-n upper-triangular factor r_tsqr; ! c) matrix t and array work for stdlib${ii}$_dorgtsqr_row; ! d) diagonal d for stdlib${ii}$_dorhr_col. if( lwork<n*n+1 .and. .not.lquery ) then info = -11_${ik}$ else ! set block size for column blocks nb1local = min( nb1, n ) num_all_row_blocks = max( 1_${ik}$,ceiling( real( m - n,KIND=dp) / real( mb1 - n,& KIND=dp) ) ) ! length and leading dimension of work array to place ! t array in tsqr. lwt = num_all_row_blocks * n * nb1local ldwt = nb1local ! length of tsqr work array lw1 = nb1local * n ! length of stdlib${ii}$_dorgtsqr_row work array. lw2 = nb1local * max( nb1local, ( n - nb1local ) ) lworkopt = max( lwt + lw1, max( lwt+n*n+lw2, lwt+n*n+n ) ) if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -11_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGETSQRHRT', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end if nb2local = min( nb2, n ) ! (1) perform tsqr-factorization of the m-by-n matrix a. call stdlib${ii}$_dlatsqr( m, n, mb1, nb1local, a, lda, work, ldwt,work(lwt+1), lw1, iinfo ) ! (2) copy the factor r_tsqr stored in the upper-triangular part ! of a into the square matrix in the work array ! work(lwt+1:lwt+n*n) column-by-column. do j = 1, n call stdlib${ii}$_dcopy( j, a( 1_${ik}$, j ), 1_${ik}$, work( lwt + n*(j-1)+1_${ik}$ ), 1_${ik}$ ) end do ! (3) generate a m-by-n matrix q with orthonormal columns from ! the result stored below the diagonal in the array a in place. call stdlib${ii}$_dorgtsqr_row( m, n, mb1, nb1local, a, lda, work, ldwt,work( lwt+n*n+1 ), & lw2, iinfo ) ! (4) perform the reconstruction of householder vectors from ! the matrix q (stored in a) in place. call stdlib${ii}$_dorhr_col( m, n, nb2local, a, lda, t, ldt,work( lwt+n*n+1 ), iinfo ) ! (5) copy the factor r_tsqr stored in the square matrix in the ! work array work(lwt+1:lwt+n*n) into the upper-triangular ! part of a. ! (6) compute from r_tsqr the factor r_hr corresponding to ! the reconstructed householder vectors, i.e. r_hr = s * r_tsqr. ! this multiplication by the sign matrix s on the left means ! changing the sign of i-th row of the matrix r_tsqr according ! to sign of the i-th diagonal element diag(i) of the matrix s. ! diag is stored in work( lwt+n*n+1 ) from the stdlib${ii}$_dorhr_col output. ! (5) and (6) can be combined in a single loop, so the rows in a ! are accessed only once. do i = 1, n if( work( lwt+n*n+i )==-one ) then do j = i, n a( i, j ) = -one * work( lwt+n*(j-1)+i ) end do else call stdlib${ii}$_dcopy( n-i+1, work(lwt+n*(i-1)+i), n, a( i, i ), lda ) end if end do work( 1_${ik}$ ) = real( lworkopt,KIND=dp) return end subroutine stdlib${ii}$_dgetsqrhrt #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$getsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! DGETSQRHRT: computes a NB2-sized column blocked QR-factorization !! of a real M-by-N matrix A with M >= N, !! A = Q * R. !! The routine uses internally a NB1-sized column blocked and MB1-sized !! row blocked TSQR-factorization and perfors the reconstruction !! of the Householder vectors from the TSQR output. The routine also !! converts the R_tsqr factor from the TSQR-factorization output into !! the R factor that corresponds to the Householder QR-factorization, !! A = Q_tsqr * R_tsqr = Q * R. !! The output Q and R factors are stored in the same format as in DGEQRT !! (Q is in blocked compact WY-representation). See the documentation !! of DGEQRT for more details on the format. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, nb1, nb2, mb1 ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! 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. m<n ) then info = -2_${ik}$ else if( mb1<=n ) then info = -3_${ik}$ else if( nb1<1_${ik}$ ) then info = -4_${ik}$ else if( nb2<1_${ik}$ ) then info = -5_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -7_${ik}$ else if( ldt<max( 1_${ik}$, min( nb2, n ) ) ) then info = -9_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array: ! a) matrix t and work for stdlib${ii}$_${ri}$latsqr; ! b) n-by-n upper-triangular factor r_tsqr; ! c) matrix t and array work for stdlib${ii}$_${ri}$orgtsqr_row; ! d) diagonal d for stdlib${ii}$_${ri}$orhr_col. if( lwork<n*n+1 .and. .not.lquery ) then info = -11_${ik}$ else ! set block size for column blocks nb1local = min( nb1, n ) num_all_row_blocks = max( 1_${ik}$,ceiling( real( m - n,KIND=${rk}$) / real( mb1 - n,& KIND=${rk}$) ) ) ! length and leading dimension of work array to place ! t array in tsqr. lwt = num_all_row_blocks * n * nb1local ldwt = nb1local ! length of tsqr work array lw1 = nb1local * n ! length of stdlib${ii}$_${ri}$orgtsqr_row work array. lw2 = nb1local * max( nb1local, ( n - nb1local ) ) lworkopt = max( lwt + lw1, max( lwt+n*n+lw2, lwt+n*n+n ) ) if( ( lwork<max( 1_${ik}$, lworkopt ) ).and.(.not.lquery) ) then info = -11_${ik}$ end if end if end if ! handle error in the input parameters and return workspace query. if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DGETSQRHRT', -info ) return else if ( lquery ) then work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end if ! quick return if possible if( min( m, n )==0_${ik}$ ) then work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end if nb2local = min( nb2, n ) ! (1) perform tsqr-factorization of the m-by-n matrix a. call stdlib${ii}$_${ri}$latsqr( m, n, mb1, nb1local, a, lda, work, ldwt,work(lwt+1), lw1, iinfo ) ! (2) copy the factor r_tsqr stored in the upper-triangular part ! of a into the square matrix in the work array ! work(lwt+1:lwt+n*n) column-by-column. do j = 1, n call stdlib${ii}$_${ri}$copy( j, a( 1_${ik}$, j ), 1_${ik}$, work( lwt + n*(j-1)+1_${ik}$ ), 1_${ik}$ ) end do ! (3) generate a m-by-n matrix q with orthonormal columns from ! the result stored below the diagonal in the array a in place. call stdlib${ii}$_${ri}$orgtsqr_row( m, n, mb1, nb1local, a, lda, work, ldwt,work( lwt+n*n+1 ), & lw2, iinfo ) ! (4) perform the reconstruction of householder vectors from ! the matrix q (stored in a) in place. call stdlib${ii}$_${ri}$orhr_col( m, n, nb2local, a, lda, t, ldt,work( lwt+n*n+1 ), iinfo ) ! (5) copy the factor r_tsqr stored in the square matrix in the ! work array work(lwt+1:lwt+n*n) into the upper-triangular ! part of a. ! (6) compute from r_tsqr the factor r_hr corresponding to ! the reconstructed householder vectors, i.e. r_hr = s * r_tsqr. ! this multiplication by the sign matrix s on the left means ! changing the sign of i-th row of the matrix r_tsqr according ! to sign of the i-th diagonal element diag(i) of the matrix s. ! diag is stored in work( lwt+n*n+1 ) from the stdlib${ii}$_${ri}$orhr_col output. ! (5) and (6) can be combined in a single loop, so the rows in a ! are accessed only once. do i = 1, n if( work( lwt+n*n+i )==-one ) then do j = i, n a( i, j ) = -one * work( lwt+n*(j-1)+i ) end do else call stdlib${ii}$_${ri}$copy( n-i+1, work(lwt+n*(i-1)+i), n, a( i, i ), lda ) end if end do work( 1_${ik}$ ) = real( lworkopt,KIND=${rk}$) return end subroutine stdlib${ii}$_${ri}$getsqrhrt #:endif #:endfor pure module subroutine stdlib${ii}$_cgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! CGETSQRHRT computes a NB2-sized column blocked QR-factorization !! of a complex M-by-N matrix A with M >= N, !! A = Q * R. !! The routine uses internally a NB1-sized column blocked and MB1-sized !! row blocked TSQR-factorization and perfors the reconstruction !! of the Householder vectors from the TSQR output. The routine also !! converts the R_tsqr factor from the TSQR-factorization output into !! the R factor that corresponds to the Householder QR-factorization, !! A = Q_tsqr * R_tsqr = Q * R. !! The output Q and R factors are stored in the same format as in CGEQRT !! (Q is in blocked compact WY-representation). See the documentation !! of CGEQRT for more details on the format. ! -- lapack computational routine -- ! -- lapack 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, lwork, m, n, nb1, nb2, mb1 ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! 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. m<n ) then info = -2_${ik}$ else if( mb1<=n ) then info = -3_${ik}$ else if( nb1<1_${ik}$ ) then info = -4_${ik}$ else if( nb2<1_${ik}$ ) then info = -5_${ik}$ else if( lda<max( 1_${ik}$, m ) ) then info = -7_${ik}$ else if( ldt<max( 1_${ik}$, min( nb2, n ) ) ) then info = -9_${ik}$ else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array: ! a) matrix t and work for stdlib${ii}$_clatsqr; ! b) n-by-n upper-triangular factor r_tsqr; ! c) matrix t and array work for stdlib${ii}$_cungtsqr_row; ! d) diagonal d for stdlib${ii}$_cunhr_col. if( lwork<n*n+1 .and. .not.lquery ) then info = -11_${ik}$ else ! set block size for column blocks nb1local = min( nb1, n ) num_all_row_blocks = max( 1_${ik}$,ceiling( real( m - n,KIND=sp) / real( mb1 - n,& KIND=sp) )